Require Import Nat Lia.
Require Import List Streams RelationClasses Morphisms.
Import ListNotations.

From CasperCBC
Require Import Lib.Preamble Lib.ListExtras Lib.StreamExtras.

(** * VLSM Basics

This module provides basic VLSM infrastructure.
*)

(** ** VLSM definition

*** The type of a VLSM

The type of a VLSM is a triple consisting of the underlying types of
messages, states, and labels.

In Coq it is defined as a Class taking <<message>> as parameter and having
[state] and [label] as fields.  <<message>> is a parameter to allow it to be
easily shared by multiple VLSMs during composition.
*)

Class VLSM_type (message : Type) :=
  { state : Type
  ; label : Type
  }.

(** *** The signature of a VLSM

Although the VLSM definition does not single out the notion of a VLSM
signature, we find it convenient to extract it as the [VLSM_sign] class.

The [VLSM_sign] class is parameterized by a [VLSM_type] and defines properties
for initial states ([initial_state_prop]) and initial messages
([initial_message_prop]), from which we can immediately define the dependent
types [initial_state] (as [state]s having the [initial_state_prop]erty) and
[intial_message] (as <<message>>s having the [initial_message_prop]erty).

Additionally, [VLSM_sign] requires the identification of an [initial_state] [s0],
a <<message>> [m0], and a [label] [l0] to ensure the non-emptiness of the
corresponding sets.
*)

  Class VLSM_sign {message : Type} (vtype : VLSM_type message) :=
    { initial_state_prop : state -> Prop
    ; initial_state := { s : state | initial_state_prop s }
    ; initial_message_prop : message -> Prop
    ; initial_message := { m : message | initial_message_prop m }
    ; s0 : initial_state
    ; m0 : message
    ; l0 : label
    }.

  Definition option_initial_message_prop
    {message : Type} {vtype : VLSM_type message} {sign : VLSM_sign vtype}
    (om : option message) : Prop
    := match om with
       | None => True
       | Some m => initial_message_prop m
       end.

  Definition VLSM_sign_pre_loaded_with_messages
    {message : Type} {vtype : VLSM_type message} (sign : VLSM_sign vtype)
    (initial : message -> Prop)
    : VLSM_sign vtype
    :=
    {| initial_state_prop := @initial_state_prop _ _ sign
    ; initial_message_prop := fun m => @initial_message_prop _ _ sign  m \/ initial m
    ; s0 := @s0 _ _ sign
    ; m0 := @m0 _ _ sign
    ; l0 := @l0 _ _ sign
    |}.

  Definition decidable_initial_messages_prop
    {message : Type} {vtype : VLSM_type message} (sign : VLSM_sign vtype)
    := forall m, Decision (initial_message_prop m).

(** *** VLSM class definition

Given a [VLSM_sign]nature, a [VLSM] is defined by providing a [transition]
function and a [valid]ity condition.
*)

  Class VLSM_class {message : Type} {vtype : VLSM_type message} (lsm : VLSM_sign vtype) :=
    { transition : label -> state * option message -> state * option message
    ; valid : label -> state * option message -> Prop
    }.

  Definition VLSM_class_pre_loaded_with_messages
    {message : Type} {vtype : VLSM_type message} {lsm : VLSM_sign vtype} (vlsm : VLSM_class lsm)
    (initial : message -> Prop)
    : VLSM_class (VLSM_sign_pre_loaded_with_messages lsm initial)
    :=
    {| transition := @transition _ _ _ vlsm
     ; valid := @valid _ _ _ vlsm
    |}.

  Definition VLSM (message : Type) :=
    sigT (fun T : VLSM_type message =>
      sigT (fun S : VLSM_sign T => VLSM_class S)).

  Definition mk_vlsm
    {message : Type}
    {T : VLSM_type message}
    {S : VLSM_sign T}
    (M : VLSM_class S)
    : VLSM message
    := existT _ T (existT _ S M).

  Definition pre_loaded_vlsm
    {message : Type}
    (X : VLSM message)
    (initial : message -> Prop)
    : VLSM message
    :=
    let M := projT2 (projT2 X) in
    let M' := VLSM_class_pre_loaded_with_messages M initial in
    mk_vlsm M'.

Section Traces.

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

(** ** Traces

We introduce the concept of a trace to formalize an execution of the protocol.
It is abstracted as a pair <<(start, steps)>> where <<start>> is a state
and <<steps>> is a tuple of objects which fully describe the transitions
underwent during execution. Notably, <<steps>> might be infinite.

In Coq, we can define these objects (which we name [transition_item]s) as consisting of:
- the [label] [l]
- the (optional) [input] <<message>>
- the [destination] [state] of the transition
- the (optional) [output] <<message>> generated by the transition
*)

  Record transition_item :=
    {   l : label
        ;   input : option message
        ;   destination : state
        ;   output : option message
    }.

    Definition field_selector
               (field: transition_item -> option message) :
      (message -> transition_item -> Prop) :=
      fun m item => field item = Some m.

    Definition item_sends_or_receives:
      message -> transition_item -> Prop :=
      fun m item => input item = Some m \/ output item = Some m.

    Definition trace_has_message
      (message_selector : message -> transition_item -> Prop)
      (msg : message)
      (tr : list transition_item)
      : Prop
      := List.Exists (message_selector msg) tr.

    (** Defines a message received but not sent by within the trace. *)
    Definition trace_received_not_sent_before_or_after
      (tr : list transition_item)
      (m : message)
      : Prop
      := trace_has_message (field_selector input) m tr /\
         ~trace_has_message (field_selector output) m tr.

    (** States that a property holds for all messages received but not sent by a trace. *)
    Definition trace_received_not_sent_before_or_after_invariant
      (tr : list transition_item)
      (P : message -> Prop)
      : Prop
      := forall m, trace_received_not_sent_before_or_after tr m -> P m.

  (** 'proto_run's are used for an alternative definition of 'protocol_prop' which
  takes into account transitions. See 'vlsm_run_prop'.
  *)
  Record proto_run : Type := mk_proto_run
    { start : state
      ; transitions : list transition_item
      ; final : state * option message
    }.

  Inductive Trace : Type :=
  | Finite : state -> list transition_item -> Trace
  | Infinite : state -> Stream transition_item -> Trace.

  Definition trace_first (tr : Trace) : state :=
    match tr with
    | Finite s _ => s
    | Infinite s _ => s
    end.

  Definition finite_trace_last
    (si : state) (tr : list transition_item) : state :=
    last (List.map destination tr) si.

  Definition finite_trace_nth
    (si : state) (tr : list transition_item)
    : nat -> option state :=
  nth_error (si :: List.map destination tr).

  Definition trace_last (tr : Trace) : option state
    :=
      match tr with
      | Finite s ls => Some (finite_trace_last s ls)
      | Infinite _ _ => None
      end.

(**
Next function extract the nth state of a trace, where the sequence of
states of a trace is obtained by appending the all destination
states in the transition list/stream to the initial state of the trace.
*)
  Definition trace_nth (tr : Trace)
    : nat -> option state :=
    fun (n : nat) =>
      match tr with
      | Finite s ls => finite_trace_nth s ls n
      | Infinite s st => Some (Str_nth n (Cons s (Streams.map destination st)))
      end.

End Traces.

Arguments transition_item {message} {T} , {message} T.
Arguments field_selector {_} {T} _ msg item / .
Arguments item_sends_or_receives {_} {_} msg item /.

Section TraceLemmas.

  Context
    [message : Type]
    [T : VLSM_type message]
    .

  Lemma last_error_destination_last
    (tr : list transition_item)
    (s : state)
    (Hlast : option_map destination (last_error tr) = Some s)
    (default : state)
    : finite_trace_last default tr  = s.
  Proof.
    unfold option_map in Hlast.
    destruct (last_error tr) eqn : eq; try discriminate Hlast.
    inversion Hlast.
    unfold last_error in eq.
    destruct tr; try discriminate eq.
    inversion eq.
    unfold finite_trace_last.
    rewrite last_map. reflexivity.
  Qed.

  Lemma finite_trace_last_cons
    s x tl:
    finite_trace_last s (x::tl) = finite_trace_last (destination x) tl.
  Proof.
    unfold finite_trace_last. rewrite map_cons, unroll_last. reflexivity.
  Qed.

  Lemma finite_trace_last_nil
    s:
    finite_trace_last s [] = s.
  Proof. reflexivity. Qed.

  Lemma finite_trace_last_app
    s t1 t2:
    finite_trace_last s (t1 ++ t2) = finite_trace_last (finite_trace_last s t1) t2.
  Proof.
    unfold finite_trace_last.
    rewrite map_app, last_app.
    reflexivity.
  Qed.

  Lemma finite_trace_last_is_last
    s x tl:
    finite_trace_last s (tl++[x]) = destination x.
  Proof.
    unfold finite_trace_last.
    rewrite map_app.
    simpl.
    rewrite last_is_last.
    reflexivity.
  Qed.

  Lemma finite_trace_nth_first
    (si : state) (tr : list transition_item):
    finite_trace_nth si tr 0 = Some si.
  Proof.
    reflexivity.
  Qed.

  Lemma finite_trace_nth_last
    (si : state) (tr : list transition_item):
    finite_trace_nth si tr (length tr) = Some (finite_trace_last si tr).
  Proof.
    unfold finite_trace_nth, finite_trace_last.
    destruct tr;[reflexivity|].
    cbn [nth_error length].
    apply nth_error_last.
    rewrite map_length.
    reflexivity.
  Qed.

  Lemma finite_trace_nth_app1
    (si : state) (t1 t2 : list transition_item) n:
    n <= length t1 ->
    finite_trace_nth si (t1++t2) n = finite_trace_nth si t1 n.
  Proof.
    intro H.
    unfold finite_trace_nth.
    rewrite map_app, app_comm_cons.
    apply nth_error_app1.
    simpl. rewrite map_length.
    auto with arith.
  Qed.

  Lemma finite_trace_nth_app2
    (si : state) (t1 t2 : list transition_item) n:
    length t1 <= n ->
    finite_trace_nth si (t1++t2) n = finite_trace_nth (finite_trace_last si t1) t2 (n - length t1).
  Proof.
    intro H.
    apply Compare_dec.le_lt_eq_dec in H.
    destruct H as [H |<-].
    - unfold finite_trace_nth.
      rewrite map_app, app_comm_cons.
      rewrite nth_error_app2;simpl length;rewrite map_length;[|solve[auto with arith]].
      destruct n;[exfalso;lia|].
      replace (S n -length t1) with (S (n - length t1)) by lia.
      reflexivity.
    - rewrite finite_trace_nth_app1, finite_trace_nth_last by reflexivity.
      rewrite PeanoNat.Nat.sub_diag, finite_trace_nth_first.
      reflexivity.
  Qed.

  Lemma finite_trace_nth_length
    (si : state) (tr : list transition_item) n s:
    finite_trace_nth si tr n = Some s ->
    n <= length tr.
  Proof.
    intros H.
    apply nth_error_length in H.
    simpl in H.
    rewrite map_length in H.
    apply le_S_n in H.
    assumption.
  Qed.

  Lemma finite_trace_last_prefix
    (s: state) (tr: list transition_item) n nth:
    finite_trace_nth s tr n = Some nth ->
    finite_trace_last s (list_prefix tr n) = nth.
  Proof.
    unfold finite_trace_nth, finite_trace_last.
    rewrite list_prefix_map.
    generalize (List.map destination tr); intro l; clear tr.
    destruct n.
    - simpl. intros [=<-]. destruct l;reflexivity.
    - simpl. intro H. symmetry. revert H s.
      apply list_prefix_nth_last.
  Qed.

  Lemma finite_trace_last_suffix
    (s: state) (tr: list transition_item) n:
    n < length tr ->
    finite_trace_last s (list_suffix tr n) = finite_trace_last s tr.
  Proof.
    intros H.
    unfold finite_trace_last.
    rewrite list_suffix_map.
    apply list_suffix_last.
    rewrite map_length.
    assumption.
  Qed.

  Lemma unlock_finite_trace_last s tr:
    finite_trace_last s tr = last (List.map destination tr) s.
  Proof.
    reflexivity.
  Qed.
  Opaque finite_trace_last.

End TraceLemmas.

Section vlsm_projections.

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

(**
Given a [VLSM], it is convenient to be able to retrieve its V[VLSM_sign]nature
or [VLSM_type]. Functions [sign] and [type] below achieve this precise purpose.
*)

  Definition type := projT1 vlsm.
  Definition sign := projT1 (projT2 vlsm).
  Definition machine := projT2 (projT2 vlsm).
  Definition vstate := @state _ type.
  Definition vlabel := @label _ type.
  Definition vinitial_state_prop := @initial_state_prop _ _ sign.
  Definition vinitial_state := @initial_state _ _ sign.
  Definition vinitial_message_prop := @initial_message_prop _ _ sign.
  Definition voption_initial_message_prop := @option_initial_message_prop _ _ sign.
  Definition vinitial_message := @initial_message _ _ sign.
  Definition vs0 := @s0 _ _ sign.
  Definition vm0 := @m0 _ _ sign.
  Definition vl0 := @l0 _ _ sign.
  Definition vdecidable_initial_messages_prop := @decidable_initial_messages_prop _ _ sign.
  Definition vtransition := @transition _ _ _ machine.
  Definition vvalid := @valid _ _ _ machine.
  Definition vtransition_item := @transition_item _ type.
  Definition vTrace := @Trace _ type.
  Definition vproto_run := @proto_run _ type.

End vlsm_projections.

Lemma mk_vlsm_machine
  {message : Type}
  (X : VLSM message)
  : mk_vlsm (machine X) = X.
Proof.
  destruct X as (T, (S, M)). reflexivity.
Qed.

  Section VLSM.

(**
In this section we assume a fixed [VLSM].
*)

    Context
      {message : Type}
      (X : VLSM message)
      (TypeX := type X)
      (SignX := sign X)
      (MachineX := machine X)
      .

Existing Instance TypeX.
Existing Instance SignX.
Existing Instance MachineX.

(** *** Protocol states and messages

We further characterize certain objects as being _protocol_, which means they can
be witnessed or experienced during executions of the protocol. For example,
a message is a [protocol_message] if there exists an execution of the protocol
in which it is produced.

We choose here to define protocol states and messages together as the
[protocol_prop] property, inductively defined over the
[state * option message] product type,
as this definition avoids the need of using a mutually recursive definition.

The inductive definition has three cases:
- if <<s>> is a [state] with the [initial_state_prop]erty, then <<(s, None)>> has the [protocol_prop]erty;
- if <<m>> is a <<message>> with the [initial_message_prop]erty, then <<(>>[s0, Some]<< m)>> has the [protocol_prop]erty;
- for all [state]s <<s>>, [option]al <<message>> <<om>>,
  and [label] <<l>>:

  if there is an (optional) <<message>> <<_om>> such that <<(s, _om)>> has the [protocol_prop]erty;

  and if there is a [state] <<_s>> such that <<(_s, om)>> has the [protocol_prop]erty;

  and if <<l>> [valid] <<(s, om)>>,

  then [transition] <<l (s, om)>> has the [protocol_prop]erty.
*)

    Inductive protocol_prop : state * option message -> Prop :=
    | protocol_initial
        (s : state)
        (Hs : initial_state_prop s)
        (om : option message)
        (Hom : option_initial_message_prop om)
      : protocol_prop (s, om)
    | protocol_generated
        (l : label)
        (s : state)
        (_om : option message)
        (Hps : protocol_prop (s, _om))
        (_s : state)
        (om : option message)
        (Hpm : protocol_prop (_s, om))
        (Hv : valid l (s, om))
      : protocol_prop (transition l (s, om)).
    Definition protocol_initial_state
      [s:state] (Hs: initial_state_prop s)
      : protocol_prop (s,None)
      := protocol_initial s Hs None I.

(**

The [protocol_state_prop]erty and the [protocol_message_prop]erty are now
definable as simple projections of the above definition.

Moreover, we use these derived properties to define the corresponding
dependent types [protocol_state] and [protocol_message].

*)

    Definition protocol_state_prop (s : state) :=
      exists om : option message, protocol_prop (s, om).

    Definition protocol_message_prop (m : message) :=
      exists s : state, protocol_prop (s, (Some m)).

    Definition protocol_state : Type :=
      { s : state | protocol_state_prop s }.

    Definition protocol_message : Type :=
      { m : message | protocol_message_prop m }.

    Lemma initial_is_protocol
      (s : state)
      (Hinitial : initial_state_prop s) :
      protocol_state_prop s.
    Proof.
      exists None.
      apply protocol_initial.
      assumption.
      exact I.
    Qed.

    Lemma initial_message_is_protocol
      (m : message)
      (Hinitial : initial_message_prop m) :
      protocol_message_prop m.
    Proof.
      exists (proj1_sig s0).
      apply protocol_initial.
      apply proj2_sig.
      assumption.
    Qed.

(**
As often times we work with optional protocol messages, it is convenient
to define a protocol message property for optional messages:
*)

    Definition option_protocol_message_prop (om : option message) :=
      exists s : state, protocol_prop (s, om).

    Lemma option_protocol_message_None
      : option_protocol_message_prop None.
    Proof.
      exists (proj1_sig s0).
      apply protocol_initial.
      apply proj2_sig.
      exact I.
    Qed.

    Lemma option_protocol_message_Some
      (m : message)
      (Hpm : protocol_message_prop m)
      : option_protocol_message_prop (Some m).
    Proof.
      destruct Hpm as [s Hpm]. exists s. assumption.
    Qed.

    Lemma option_initial_message_is_protocol
      (om : option message)
      (Hinitial : option_initial_message_prop om) :
      option_protocol_message_prop om.
    Proof.
      destruct om;
      [apply option_protocol_message_Some
      |apply option_protocol_message_None].
      apply initial_message_is_protocol;assumption.
    Qed.

(** *** Protocol validity and protocol transitions

To achieve this, it is useful to further define _protocol_ validity and
_protocol_ transitions:
*)

    Definition protocol_valid
               (l : label)
               (som : state * option message)
      : Prop
      :=
      let (s, om) := som in
         protocol_state_prop s
      /\ option_protocol_message_prop om
      /\ valid l (s,om).

    Definition protocol_transition
      (l : label)
      (som : state * option message)
      (som' : state * option message)
      :=
      protocol_valid l som
      /\  transition l som = som'.

    Definition protocol_transition_preserving
      (R : state -> state -> Prop)
      : Prop
      :=
      forall
        (s1 s2 : state)
        (l : label)
        (om1 om2 : option message)
        (Hprotocol: protocol_transition l (s1, om1) (s2, om2)),
        R s1 s2.

(**
  Next three lemmas show the two definitions above are strongly related.
*)

    Lemma protocol_transition_valid
      (l : label)
      (som : state * option message)
      (som' : state * option message)
      (Ht : protocol_transition l som som')
      : protocol_valid l som.
    Proof.
      destruct Ht as [Hpv Ht].
      assumption.
    Qed.

    Lemma protocol_valid_transition
      (l : label)
      (som : state * option message)
      (Hv : protocol_valid l som)
      : exists (som' : state * option message),
        protocol_transition l som som'.
    Proof.
      exists (transition l som).
      repeat split; assumption.
    Qed.

    Lemma protocol_valid_transition_iff
      (l : label)
      (som : state * option message)
      : protocol_valid l som
      <-> exists (som' : state * option message),
            protocol_transition l som som'.
    Proof.
      split.
      - apply protocol_valid_transition.
      - intros [som' Hpt].
        apply protocol_transition_valid with som'.
        assumption.
    Qed.

(**

The next couple of lemmas relate the two definitions above with
pre-existing concepts.

 *)
    Lemma protocol_generated_valid
      {l : label}
      {s : state}
      {_om : option message}
      {_s : state}
      {om : option message}
      (Hps : protocol_prop (s, _om))
      (Hpm : protocol_prop (_s, om))
      (Hv : valid l (s, om))
      : protocol_valid l (s, om).
    Proof.
      repeat split; try assumption.
      - exists _om. assumption.
      - exists _s. assumption.
    Qed.

    Lemma protocol_transition_origin
          {l : label}
          {s s' : state}
          {om om' : option message}
          (Ht : protocol_transition l (s, om) (s',om'))
      : protocol_state_prop s.
    Proof.
      destruct Ht as [[[_om Hp] _] _]. exists _om. assumption.
    Qed.

    Lemma protocol_transition_destination
          {l : label}
          {s s' : state}
          {om om' : option message}
          (Ht : protocol_transition l (s, om) (s', om'))
      : protocol_state_prop s'.
    Proof.
      exists om'.
      destruct Ht as [[[_om Hs] [[_s Hom] Hv]] Ht].
      rewrite <- Ht. apply protocol_generated with _om _s; assumption.
    Qed.

    Lemma protocol_transition_in
          {l : label}
          {s s' : state}
          {om om' : option message}
          (Ht : protocol_transition l (s, om) (s', om'))
      : option_protocol_message_prop om.
    Proof.
      destruct Ht as [[_ [[_s Hom] _]] _].
      exists _s. assumption.
    Qed.

    Lemma protocol_prop_transition_out
          {l : label}
          {s s' : state}
          {om om' : option message}
          (Ht : protocol_transition l (s, om) (s', om'))
        : protocol_prop (s', om').
    Proof.
      destruct Ht as [[[_om Hps] [[_s Hpm] Hv]] Ht].
      rewrite <- Ht.
      apply protocol_generated with _om _s; assumption.
    Qed.

    Lemma protocol_transition_out
          {l : label}
          {s s' : state}
          {om om' : option message}
          (Ht : protocol_transition l (s, om) (s', om'))
      : option_protocol_message_prop om'.
    Proof.
      apply protocol_prop_transition_out in Ht.
      exists s'. assumption.
    Qed.

    Lemma protocol_transition_is_valid
          {l : label}
          {s s' : state}
          {om om' : option message}
          (Ht : protocol_transition l (s, om) (s', om'))
      : valid l (s, om).
    Proof.
      destruct Ht as [[_ [_ Hv]] _].
      assumption.
    Qed.

    Lemma protocol_transition_transition
          {l : label}
          {s s' : state}
          {om om' : option message}
          (Ht : protocol_transition l (s, om) (s', om'))
        :  transition l (s, om) = (s', om').
     Proof.
      destruct Ht as [_ Ht]. assumption.
     Qed.

    Lemma protocol_prop_valid_out
      (l : label)
      (s : state)
      (om : option message)
      (Hv : protocol_valid l (s, om))
      : protocol_prop (transition l (s, om)).
    Proof.
      apply protocol_valid_transition in Hv.
      destruct Hv as [[s' om'] Ht].
      specialize (protocol_transition_transition  Ht); intro Hteq.
      rewrite Hteq.
      apply (protocol_prop_transition_out Ht).
    Qed.

    (** For VLSMs initialized with many initial messages such as
    the [composite_vlsm_constrained_projection] or the [pre_loaded_with_all_messages_vlsm],
    the question of whether a [VLSM] [can_emit] a message <<m>> becomes more
    useful than that whether <<m>> is a [protocol_message].
    *)

    Definition protocol_generated_prop
      (s : state)
      (m : message)
      :=
      exists
      (som : state * option message)
      (l : label),
      protocol_transition l som (s, Some m).

    (** Of course, if a VLSM [can_emit] <<(s,m)>>, then <<(s,m)>> is protocol.
    *)

    Lemma protocol_generated_prop_protocol
      (s : state)
      (m : message)
      (Hm : protocol_generated_prop s m)
      : protocol_prop (s, Some m) .
    Proof.
      destruct Hm as [(s0, om0) [l [[[_om0 Hs0] [[_s0 Hom0] Hv]] Ht]]].
      rewrite <- Ht.
      apply protocol_generated with _om0 _s0; assumption.
    Qed.

    Definition can_emit
      (m : message)
      :=
      exists
      (som : state * option message)
      (l : label)
      (s : state),
      protocol_transition l som (s, Some m).

    Lemma can_emit_iff
      (m : message)
      : can_emit m <-> exists s, protocol_generated_prop s m.
    Proof.
      split.
      - intros [som [l [s Ht]]]. exists s, som, l. assumption.
      - intros [s [som [l Ht]]]. exists som, l, s. assumption.
    Qed.

    (** If a VLSM [can_emit] a message <<m>>, then <<m>> is protocol.
    *)

    Lemma can_emit_protocol
      (m : message)
      (Hm : can_emit m)
      : protocol_message_prop m .
    Proof.
      apply can_emit_iff in Hm.
      destruct Hm as [s Hm].
      apply protocol_generated_prop_protocol in Hm.
      exists s. assumption.
    Qed.

    (** A characterization of protocol messages in terms of [can_emit]
    *)

    Lemma can_emit_protocol_iff
      (m : message)
      : protocol_message_prop m <-> initial_message_prop m \/ can_emit m.
    Proof.
      split.
      - intros [s Hm]; inversion Hm; subst.
        + left. assumption.
        + right.
          exists (s1, om). exists l1. exists s.
          repeat split; try assumption.
          * exists _om. assumption.
          * exists _s. assumption.
      - intros [Him | Hem].
        + apply initial_message_is_protocol. assumption.
        + apply can_emit_protocol. assumption.
    Qed.

(** *** Protocol state and protocol message characterization

The definition and results below show that the mutually-recursive definitions
for [protocol_state]s and [protocol_message]s can be derived from the
prior definitions.

The results below offers equivalent characterizations for [protocol_state]s
and [protocol_message]s, similar to their recursive definition.
*)

    Lemma protocol_state_prop_iff :
      forall s' : state,
        protocol_state_prop s'
        <-> (exists is : initial_state, s' = proj1_sig is)
          \/ exists (l : label) (som : state * option message) (om' : option message),
            protocol_transition l som (s', om').
    Proof.
      intros; split.
      - intro Hps'. destruct Hps' as [om' Hs].
        inversion Hs; subst.
        * left. exists (exist _ _ Hs0). reflexivity.
        * right. exists l1. exists (s, om). exists om'.
          repeat split; try assumption.
          + exists _om. assumption.
          + exists _s. assumption.
      - intros [[[s His] Heq] | [l [[s om] [om' [[[_om Hps] [[_s Hpm] Hv]] Ht]]]]]; subst.
        + exists None. apply protocol_initial; [assumption | exact I].
        + exists om'. rewrite <- Ht. apply protocol_generated with _om _s; assumption.
    Qed.

    (** A specialized induction principle for [protocol_state_prop].

        Compared to opening the existential and using [protocol_prop_ind],
        this avoids the redundancy of the [protocol_initial_state] case
        needing a proof for any [initial_state] and then [protocol_initial_message]
        asking for a proof specifically for [s0], and also avoids the
        little trouble of needing <<set>> or <<dependent induction>> to
        handle the pair in the index in [protocol_prop (s,om)].
     *)
    Lemma protocol_state_prop_ind
      (P : state -> Prop)
      (IHinit : forall (s : state) (Hs : initial_state_prop s), P s)
      (IHgen :
        forall (s' : state) (l: label) (om om' : option message) (s : state)
          (Ht : protocol_transition l (s, om) (s', om')) (Hs : P s),
          P s'
      )
      : forall (s : state) (Hs : protocol_state_prop s), P s.
    Proof.
      intros.
      destruct Hs as [om Hs].
      remember (s, om) as som.
      generalize dependent om. generalize dependent s.
      induction Hs; intros; inversion Heqsom; subst.
      - apply IHinit. assumption.
      - specialize (IHgen s1 l1 om om0 s).
        specialize (IHHs1 s _om eq_refl).
        apply IHgen; try assumption.
        repeat split; try assumption.
        + exists _om. assumption.
        + exists _s. assumption.
    Qed.

    (* Protocol message characterization - similar to the definition in the report. *)

    Lemma protocol_message_prop_iff :
      forall m' : message,
        protocol_message_prop m'
        <-> (exists im : initial_message, m' = proj1_sig im)
          \/ exists (l : label) (som : state * option message) (s' : state),
            protocol_transition l som (s', Some m').
    Proof.
      intros; split.
      - intros [s' Hpm'].
        inversion Hpm'; subst.
        + left. exists (exist _ m' Hom). reflexivity.
        + right. exists l1. exists (s, om). exists s'.
          firstorder.
      - intros [[[s His] Heq] | [l [[s om] [s' [[[_om Hps] [[_s Hpm] Hv]] Ht]]]]]; subst.
        + apply initial_message_is_protocol. assumption.
        + exists s'. rewrite <- Ht.
          apply protocol_generated with _om _s; assumption.
    Qed.

(** ** Trace Properties

Note that it is unnecessary to specify the source state of the transition,
as it is implied by the preceding [transition_item] (or by the <<start>> state,
if such an item doesn't exist).
*)

(**
We will now split our groundwork for defining traces into the finite case and
the infinite case.
*)

(** *** Finite [protocol_trace]s

A [finite_protocol_trace_from] a [state] <<start>> is a pair <<(start, steps)>> where <<steps>>
is a list of [transition_item]s, and is inductively defined by:
- <<(s, [])>> is a [finite_protocol_trace_from] <<s>>
- if there is a [protocol_transition] <<l (s', iom) (s, oom)>>

  and if <<(s,steps)>> is a [protocol_trace_from] <<s>>

  then <<(s', ({| l := l; input := iom; destination := s; output := oom |} :: steps)>>
  is a [protocol_transition_from] <<s'>>.

Note that the definition is given such that it extends an existing trace by
adding a transition to its front.
The reason for this choice is to have this definition be similar to the one
for infinite traces, which can only be extended at the front.
*)

    Inductive finite_protocol_trace_from : state -> list transition_item -> Prop :=
    | finite_ptrace_empty : forall (s : state), protocol_state_prop s -> finite_protocol_trace_from s []
    | finite_ptrace_extend : forall  (s : state) (tl : list transition_item),
        finite_protocol_trace_from s tl ->
        forall (s' : state) (iom oom : option message) (l : label),
          protocol_transition l (s', iom) (s, oom) ->
          finite_protocol_trace_from  s' ({| l := l; input := iom; destination := s; output := oom |} :: tl).

    Definition finite_ptrace_singleton :
      forall {l : label} {s s': state} {iom oom : option message},
        protocol_transition l (s, iom) (s', oom) ->
        finite_protocol_trace_from  s ({| l := l; input := iom; destination := s'; output := oom |} :: [])
      := fun l s s' iom oom Hptrans =>
           finite_ptrace_extend s' []
               (finite_ptrace_empty s' (protocol_transition_destination Hptrans))
               _ _ _ _ Hptrans.

(**
To complete our definition of a finite protocol trace, we must also guarantee that <<start>> is an
initial state according to the protocol.
*)

    Definition finite_protocol_trace (s : state) (ls : list transition_item) : Prop :=
      finite_protocol_trace_from s ls /\ initial_state_prop s.

    Opaque finite_protocol_trace.

(**
In the remainder of the section we provide various results allowing us to
decompose the above properties in proofs.
*)

    Lemma finite_ptrace_first_valid_transition
          (s : state)
          (tr : list transition_item)
          (te : transition_item)
          (Htr : finite_protocol_trace_from s (te :: tr))
      : protocol_transition (l te) (s, input te) (destination te, output te).
    Proof.
      inversion Htr. assumption.
    Qed.

    Lemma finite_ptrace_first_pstate
      (s : state)
      (tr : list transition_item)
      (Htr : finite_protocol_trace_from s tr)
      : protocol_state_prop s.
    Proof.
      inversion Htr; subst; try assumption.
      destruct H0 as [[Hs _] _]. assumption.
    Qed.

    Lemma finite_ptrace_tail
          (s : state)
          (tr : list transition_item)
          (te : transition_item)
          (Htr : finite_protocol_trace_from s (te :: tr))
      : finite_protocol_trace_from (destination te) tr.
    Proof.
      inversion Htr. assumption.
    Qed.

    Lemma finite_ptrace_last_pstate
      (s : state)
      (tr : list transition_item)
      (Htr : finite_protocol_trace_from s tr)
      : protocol_state_prop (finite_trace_last s tr).
    Proof.
      generalize dependent s.
      induction tr; intros.
      - simpl. apply finite_ptrace_first_pstate with []. assumption.
      - apply finite_ptrace_tail in Htr.
        apply IHtr in Htr.
        replace
          (finite_trace_last s (a :: tr))
          with (finite_trace_last (destination a) tr)
        ;[assumption|].
        unfold finite_trace_last.
        rewrite map_cons.
        rewrite unroll_last.
        reflexivity.
    Qed.

    Lemma protocol_transition_to
          (s : state)
          (tr : list transition_item)
          (tr1 tr2 : list transition_item)
          (te : transition_item)
          (Htr : finite_protocol_trace_from s tr)
          (Heq : tr = tr1 ++ [te] ++ tr2)
          (lst1 := finite_trace_last s tr1)
      : protocol_transition (l te) (lst1, input te) (destination te, output te).
    Proof.
      generalize dependent s. generalize dependent tr.
      induction tr1.
      - intros tr Heq s Htr. simpl in Heq; subst. inversion Htr; subst. assumption.
      - specialize (IHtr1 (tr1 ++ [te] ++ tr2) eq_refl).
        intros tr Heq is Htr; subst. inversion Htr; subst.
        simpl in IHtr1. specialize (IHtr1 s H2).
        rewrite finite_trace_last_cons.
        assumption.
    Qed.

    Lemma finite_ptrace_consecutive_valid_transition
          (s : state)
          (tr : list transition_item)
          (tr1 tr2 : list transition_item)
          (te1 te2 : transition_item)
          (Htr : finite_protocol_trace_from s tr)
          (Heq : tr = tr1 ++ [te1; te2] ++ tr2)
      : protocol_transition (l te2) (destination te1, input te2) (destination te2, output te2).
    Proof.
      change ([te1; te2] ++ tr2) with ([te1] ++ [te2] ++ tr2) in Heq.
      rewrite app_assoc in Heq.
      specialize (protocol_transition_to s tr (tr1 ++ [te1]) tr2 te2 Htr Heq)
        as Ht.
      rewrite finite_trace_last_is_last in Ht. assumption.
    Qed.

    Lemma protocol_trace_output_is_protocol
      (is : state)
      (tr : list transition_item)
      (Htr : finite_protocol_trace_from is tr)
      (m : message)
      (Houtput : List.Exists (field_selector output m) tr)
      : protocol_message_prop m.
    Proof.
      revert is Htr.
      induction Houtput;intros;inversion Htr;subst.
      - simpl in H.
        subst.
        apply protocol_transition_out in H4.
        assumption.
      - apply (IHHoutput s).
        assumption.
    Qed.

    Lemma protocol_trace_input_is_protocol
      (is : state)
      (tr : list transition_item)
      (Htr : finite_protocol_trace_from is tr)
      (m : message)
      (Hinput : List.Exists (field_selector input m) tr)
      : protocol_message_prop m.
    Proof.
      revert is Htr.
      induction Hinput;intros;inversion Htr;subst.
      - simpl in H.
        subst.
        apply protocol_transition_in in H4.
        assumption.
      - apply (IHHinput s).
        assumption.
    Qed.

    Lemma first_transition_valid
      (s : state)
      (te : transition_item)
      : finite_protocol_trace_from s [te] <-> protocol_transition (l te) (s, input te) (destination te, output te).

    Proof.
      split.
      - intro Htr.
        inversion Htr.
        assumption.
      - destruct te. simpl. intro Ht.
        apply protocol_transition_destination in Ht as Hdestination0.
        constructor; [|assumption]. constructor. assumption.
    Qed.

    Lemma extend_right_finite_trace_from
      (s1 : state)
      (ts : list transition_item)
      (Ht12 : finite_protocol_trace_from s1 ts)
      (l3 : label)
      (s2 := finite_trace_last s1 ts)
      (iom3 : option message)
      (s3 : state)
      (oom3 : option message)
      (Hv23 : protocol_transition l3 (s2, iom3) (s3, oom3))
      : finite_protocol_trace_from s1 (ts ++ [{| l := l3; destination := s3; input := iom3; output := oom3 |}]).
    Proof.
      induction Ht12.
      - simpl. apply finite_ptrace_singleton;assumption.
      - rewrite <- app_comm_cons.
        apply finite_ptrace_extend; try assumption.
        simpl in IHHt12. apply IHHt12.
        unfold s2 in *; clear s2.
        rewrite finite_trace_last_cons in Hv23.
        assumption.
    Qed.

(**
We can now prove several general properties of [finite_protocol_trace]s. For example,
the following lemma states that given two such traces, such that the latter's starting state
is equal to the former's last state, it is possible to _concatenate_ them into a single
[finite_protocol_trace].
*)

    Lemma finite_protocol_trace_from_app_iff (s : state) (ls ls' : list transition_item) (s' := finite_trace_last s ls)
      : finite_protocol_trace_from s ls /\ finite_protocol_trace_from s' ls'
        <->
        finite_protocol_trace_from s (ls ++ ls').
    Proof.
      subst s'.
      revert s.
      induction ls;intro s.
      - rewrite finite_trace_last_nil. simpl.
        intuition (eauto using finite_ptrace_first_pstate, finite_ptrace_empty).
      - rewrite finite_trace_last_cons. simpl.
        specialize (IHls (destination a)).
        split.
        + intros [Hal Hl'].
          inversion Hal; subst; simpl in *.
          constructor;[apply IHls;split|];assumption.
        + intro H.
          inversion H;subst; simpl in *.
          apply IHls in H3 as [Hl Hl'].
          split;[constructor|];assumption.
    Qed.

    Lemma finite_protocol_trace_from_rev_ind
      (P : state -> list transition_item -> Prop)
      (Hempty: forall s,
        protocol_state_prop s -> P s nil)
      (Hextend : forall s tr,
        finite_protocol_trace_from s tr ->
        P s tr ->
        forall sf iom oom l
        (Hx: protocol_transition l (finite_trace_last s tr,iom) (sf,oom)),
        let x:= {|l:=l; input:=iom; destination:=sf; output:=oom|} in
        P s (tr++[x])):
      forall s tr,
        finite_protocol_trace_from s tr ->
        P s tr.
    Proof.
      induction tr using rev_ind; intro Htr.
      - inversion Htr. apply Hempty. congruence.
      - apply finite_protocol_trace_from_app_iff in Htr.
        destruct Htr as [Htr Hx].
        destruct x; apply (Hextend _ _ Htr (IHtr Htr)).
        inversion Hx; congruence.
    Qed.

    Lemma finite_protocol_trace_rev_ind
      (P : state -> list transition_item -> Prop)
      (Hempty: forall si,
        initial_state_prop si -> P si nil)
      (Hextend : forall si tr,
        finite_protocol_trace si tr ->
        P si tr ->
        forall sf iom oom l
        (Hx: protocol_transition l (finite_trace_last si tr,iom) (sf,oom)),
        let x:= {|l:=l; input:=iom; destination:=sf; output:=oom|} in
        P si (tr++[x])):
      forall si tr,
        finite_protocol_trace si tr ->
        P si tr.
    Proof.
      intros si tr [Htr Hinit].
      induction Htr using finite_protocol_trace_from_rev_ind.
      - apply Hempty;auto.
      - apply Hextend;[split|..];auto.
    Qed.

(** Several other lemmas in this vein are necessary for proving results regarding
traces.
*)

    Lemma finite_protocol_trace_from_prefix
      (s : state)
      (ls : list transition_item)
      (Htr : finite_protocol_trace_from s ls)
      (n : nat)
      : finite_protocol_trace_from s (list_prefix ls n).
    Proof.
      specialize (list_prefix_suffix ls n); intro Hdecompose.
      rewrite <- Hdecompose in Htr.
      apply finite_protocol_trace_from_app_iff in Htr.
      destruct Htr as [Hpr _].
      assumption.
    Qed.

    Lemma finite_protocol_trace_from_suffix
      (s : state)
      (ls : list transition_item)
      (Htr : finite_protocol_trace_from s ls)
      (n : nat)
      (nth : state)
      (Hnth : finite_trace_nth s ls n = Some nth)
      : finite_protocol_trace_from nth (list_suffix ls n).
    Proof.
      rewrite <- (list_prefix_suffix ls n) in Htr.
      apply finite_protocol_trace_from_app_iff in Htr.
      destruct Htr as [_ Htr].
      replace (finite_trace_last s (list_prefix ls n)) with nth in Htr;[assumption|].
      {
        destruct n.
        - rewrite finite_trace_nth_first in Hnth. injection Hnth as ->.
          destruct ls;reflexivity.
        - unfold finite_trace_last.
          rewrite list_prefix_map.
          apply list_prefix_nth_last.
          assumption.
      }
    Qed.

    Lemma finite_protocol_trace_from_segment
      (s : state)
      (ls : list transition_item)
      (Htr : finite_protocol_trace_from s ls)
      (n1 n2 : nat)
      (Hle : n1 <= n2)
      (n1th : state)
      (Hnth : finite_trace_nth s ls n1 = Some n1th)
      : finite_protocol_trace_from n1th (list_segment ls n1 n2).
    Proof.
      apply finite_protocol_trace_from_suffix with s.
      - apply finite_protocol_trace_from_prefix. assumption.
      - destruct n1;[assumption|].
        unfold finite_trace_nth in Hnth |- *.
        simpl in Hnth |- *.
        rewrite list_prefix_map.
        rewrite list_prefix_nth;assumption.
    Qed.

    (* begin hide *)

    Lemma can_emit_from_protocol_trace
      (si : state)
      (m : message)
      (tr : list transition_item)
      (Hprotocol: finite_protocol_trace si tr)
      (Hm : trace_has_message (field_selector output) m tr) :
      can_emit m.
    Proof.
      apply Exists_exists in Hm.
      destruct Hm as [x [Hin Houtput]].
      apply in_split in Hin.
      destruct Hin as [l1 [l2 Hconcat]].
      unfold can_emit.
      destruct Hprotocol.
      specialize (protocol_transition_to _ _ _ _ _ H Hconcat).
      intros.
      simpl in H1.
      rewrite Houtput in H1.
      do 3 eexists;exact H1.
    Qed.

    (* End Hide *)

(**
** Finite [protocol_trace]s with a final state
*)

(**
It is often necessary to refer to know ending state of a [finite_protocol_trace_from].
This is either the [destination] of the [last] [transition_item] in the trace, or
the starting state.
To avoid repeating reasoning about [last], we define variants of
[finite_protocol_trace_from] and [finite_protocol_trace]
that include the final state, and give appropriate induction principles.
 *)

(** The final state of a finite portion of a protocol trace.
    This is defined over [finite_protocol_trace_from] because
    an initial state is necessary in case <<tr>> is empty,
    and this allows the definition to have only one non-implicit
    parameter.
 *)

    Inductive finite_protocol_trace_from_to : state -> state -> list transition_item -> Prop :=
    | finite_ptrace_from_to_empty : forall (s : state), protocol_state_prop s -> finite_protocol_trace_from_to s s []
    | finite_ptrace_from_to_extend : forall  (s f : state) (tl : list transition_item),
        finite_protocol_trace_from_to s f tl ->
        forall (s' : state) (iom oom : option message) (l : label),
          protocol_transition l (s', iom) (s, oom) ->
          finite_protocol_trace_from_to s' f ({| l := l; input := iom; destination := s; output := oom |} :: tl).

    Lemma finite_ptrace_from_to_singleton:
        forall (s s' : state) (iom oom : option message) (l : label),
          protocol_transition l (s, iom) (s', oom) ->
          finite_protocol_trace_from_to s s' [{| l := l; input := iom; destination := s'; output := oom |}].
    Proof.
      constructor;[|assumption].
      constructor.
      apply protocol_transition_destination in H.
      assumption.
    Qed.

    Lemma finite_protocol_trace_from_to_forget_last
          s f tr : finite_protocol_trace_from_to s f tr -> finite_protocol_trace_from s tr.
    Proof.
      induction 1;constructor;auto.
    Qed.

    Lemma finite_protocol_trace_from_to_last
          s f tr : finite_protocol_trace_from_to s f tr -> finite_trace_last s tr = f.
    Proof.
      induction 1.
      - apply finite_trace_last_nil.
      - rewrite finite_trace_last_cons; assumption.
    Qed.

    Lemma finite_protocol_trace_from_add_last
          s f tr :
      finite_protocol_trace_from s tr ->
      finite_trace_last s tr = f ->
      finite_protocol_trace_from_to s f tr.
    Proof.
      intro Hfrom.
      induction Hfrom.
      - rewrite finite_trace_last_nil. intros <-.
        constructor. assumption.
      - rewrite finite_trace_last_cons. simpl. intro.
        constructor;auto.
    Qed.

    Lemma finite_protocol_trace_from_to_first_pstate
          s f tr : finite_protocol_trace_from_to s f tr -> protocol_state_prop s.
    Proof.
      intro H.
      apply finite_protocol_trace_from_to_forget_last in H.
      apply finite_ptrace_first_pstate in H.
      assumption.
    Qed.

    Lemma finite_protocol_trace_from_to_last_pstate
          s f tr : finite_protocol_trace_from_to s f tr -> protocol_state_prop f.
    Proof.
      intro H.
      rewrite <- (finite_protocol_trace_from_to_last _ _ _ H).
      apply finite_ptrace_last_pstate.
      apply finite_protocol_trace_from_to_forget_last in H.
      assumption.
    Qed.

    Lemma finite_protocol_trace_from_to_app
      (m s f: state) (ls ls' : list transition_item)
      : finite_protocol_trace_from_to s m ls
        -> finite_protocol_trace_from_to m f ls'
        -> finite_protocol_trace_from_to s f (ls ++ ls').
    Proof.
      intros Hl Hl';induction Hl;simpl.
      - trivial.
      - constructor;auto.
    Qed.

    Lemma finite_protocol_trace_from_to_app_split
      (s f: state) (ls ls' : list transition_item)
      : finite_protocol_trace_from_to s f (ls ++ ls') ->
        let m := finite_trace_last s ls in
        finite_protocol_trace_from_to s m ls
        /\ finite_protocol_trace_from_to m f ls'.
    Proof.
      revert s;induction ls;intros s;simpl.
      - rewrite finite_trace_last_nil.
        intro H. split;[|assumption].
        apply finite_protocol_trace_from_to_first_pstate in H.
        constructor;assumption.
      - rewrite finite_trace_last_cons.
        inversion 1; subst; simpl in *.
        apply IHls in H4 as [].
        auto using finite_ptrace_from_to_extend.
    Qed.

    Definition finite_protocol_trace_init_to si sf tr : Prop
      := finite_protocol_trace_from_to si sf tr
          /\ initial_state_prop si.

    Lemma finite_protocol_trace_init_add_last si sf tr:
      finite_protocol_trace si tr ->
      finite_trace_last si tr = sf ->
      finite_protocol_trace_init_to si sf tr.
    Proof.
      intros [Htr Hinit] Hf.
      split;eauto using finite_protocol_trace_from_add_last.
    Qed.

    Lemma finite_protocol_trace_init_to_forget_last si sf tr:
      finite_protocol_trace_init_to si sf tr ->
      finite_protocol_trace si tr.
    Proof.
      intros [Hinit Htr].
      split;eauto using finite_protocol_trace_from_to_forget_last.
    Qed.

    Lemma finite_protocol_trace_init_to_last si sf tr:
      finite_protocol_trace_init_to si sf tr ->
      finite_trace_last si tr = sf.
    Proof.
      intros [Htr _].
      eauto using finite_protocol_trace_from_to_last.
    Qed.

    Lemma extend_right_finite_trace_from_to
      (s1 s2 : state)
      (ts : list transition_item)
      (Ht12 : finite_protocol_trace_from_to s1 s2 ts)
      (l3 : label)
      (iom3 : option message)
      (s3 : state)
      (oom3 : option message)
      (Hv23 : protocol_transition l3 (s2, iom3) (s3, oom3))
      : finite_protocol_trace_from_to s1 s3 (ts ++ [{| l := l3; destination := s3; input := iom3; output := oom3 |}]).
    Proof.
      induction Ht12.
      - simpl. apply finite_ptrace_from_to_singleton;assumption.
      - rewrite <- app_comm_cons.
        apply finite_ptrace_from_to_extend; auto.
    Qed.

    Lemma finite_protocol_trace_from_to_rev_ind
      (P : state -> state -> list transition_item -> Prop)
      (Hempty: forall si,
        protocol_state_prop si -> P si si nil)
      (Hextend : forall si s tr,
        P si s tr ->
        forall sf iom oom l,
        protocol_transition l (s,iom) (sf,oom) ->
        P si sf (tr++[{|l:=l; input:=iom; destination:=sf; output:=oom|}])):
      forall si sf tr,
        finite_protocol_trace_from_to si sf tr ->
        P si sf tr.
    Proof.
      intros si sf tr Htr.
      revert sf Htr.
      induction tr using rev_ind;
      intros sf Htr.
      - inversion Htr;subst. apply Hempty;assumption.
      - apply finite_protocol_trace_from_to_app_split in Htr.
        destruct Htr as [Htr Hstep].
        inversion Hstep;subst.
        inversion H3;subst.
        revert H4.
        apply Hextend.
        apply IHtr.
        assumption.
    Qed.

(** *** Infinite [protcol_trace]s *)

(** We now define [infinite_protocol_trace]s. The definitions
resemble their finite counterparts, adapted to the technical
necessities of defining infinite objects. Notably, <<steps>> is
stored as a stream, as opposed to a list.
*)

    CoInductive infinite_protocol_trace_from :
      state -> Stream transition_item -> Prop :=
    | infinite_ptrace_extend : forall  (s : state) (tl : Stream transition_item),
        infinite_protocol_trace_from s tl ->
        forall (s' : state) (iom oom : option message) (l : label),
          protocol_transition l (s', iom) (s, oom) ->
          infinite_protocol_trace_from  s' (Cons {| l := l; input := iom; destination := s; output := oom |}  tl).

    Definition infinite_ptrace (s : state) (st : Stream transition_item)
      := infinite_protocol_trace_from s st /\ initial_state_prop s.

(**
As for the finite case, the following lemmas help decompose teh above
definitions, mostly reducing them to properties about their finite segments.
*)
    Lemma infinite_ptrace_consecutive_valid_transition
          (is : state)
          (tr tr2 : Stream transition_item)
          (tr1 : list transition_item)
          (te1 te2 : transition_item)
          (Htr : infinite_protocol_trace_from is tr)
          (Heq : tr = stream_app (tr1 ++ [te1; te2]) tr2)
      : protocol_transition (l te2) (destination te1, input te2) (destination te2, output te2).
    Proof.
      generalize dependent is. generalize dependent tr.
      induction tr1.
      - intros tr Heq is Htr. simpl in Heq; subst. inversion Htr; subst. inversion H2; subst. assumption.
      - specialize (IHtr1 (stream_app (tr1 ++ [te1; te2]) tr2) eq_refl).
        intros tr Heq is Htr; subst. inversion Htr; subst.
        specialize (IHtr1 s H2). assumption.
    Qed.

    Lemma infinite_protocol_trace_from_app_iff
      (s : state)
      (ls : list transition_item)
      (ls' : Stream transition_item)
      (s' := finite_trace_last s ls)
      : finite_protocol_trace_from s ls /\ infinite_protocol_trace_from s' ls'
        <->
        infinite_protocol_trace_from s (stream_app ls ls').
    Proof.
      intros. generalize dependent ls'. generalize dependent s.
      induction ls; intros; split.
      - intros [_ H]. assumption.
      - simpl; intros; split; try assumption. constructor. inversion H; try assumption.
        apply (protocol_transition_origin H1).
      - simpl. intros [Htr Htr'].
        destruct a. apply infinite_ptrace_extend.
        + apply IHls. inversion Htr. split. apply H2.
          unfold s' in Htr'.
          rewrite finite_trace_last_cons in Htr'.
          assumption.
        + inversion Htr. apply H6.
       - intros. inversion H. subst. specialize (IHls s1). simpl in IHls. specialize (IHls ls'). apply IHls in H3.
         destruct H3. split.
         + constructor. apply H0. apply H4.
         + unfold s'. rewrite finite_trace_last_cons. assumption.
    Qed.

    Lemma infinite_protocol_trace_from_prefix
      (s : state)
      (ls : Stream transition_item)
      (Htr : infinite_protocol_trace_from s ls)
      (n : nat)
      : finite_protocol_trace_from s (stream_prefix ls n).
    Proof.
      specialize (stream_prefix_suffix ls n); intro Hdecompose.
      rewrite <- Hdecompose in Htr.
      apply infinite_protocol_trace_from_app_iff in Htr.
      destruct Htr as [Hpr _].
      assumption.
    Qed.

    Lemma infinite_protocol_trace_from_prefix_rev
      (s : state)
      (ls : Stream transition_item)
      (Hpref: forall n : nat, finite_protocol_trace_from s (stream_prefix ls n))
      : infinite_protocol_trace_from s ls.
    Proof.
      generalize dependent Hpref. generalize dependent s. generalize dependent ls.
      cofix H.
      intros (a, ls) s Hpref.
      assert (Hpref0 := Hpref 1).
      inversion Hpref0; subst.
      constructor; try assumption.
      apply H.
      intro n.
      specialize (Hpref (S n)).
      simpl in Hpref.
      inversion Hpref; subst.
      assumption.
    Qed.

    Lemma infinite_protocol_trace_from_segment
      (s : state)
      (ls : Stream transition_item)
      (Htr : infinite_protocol_trace_from s ls)
      (n1 n2 : nat)
      (Hle : n1 <= n2)
      (n1th := Str_nth n1 (Cons s (Streams.map destination ls)))
      : finite_protocol_trace_from n1th (stream_segment ls n1 n2).
    Proof.
      apply finite_protocol_trace_from_suffix with s.
      - apply infinite_protocol_trace_from_prefix. assumption.
      - destruct n1; try reflexivity.
        unfold n1th. clear n1th.
        unfold finite_trace_nth.
        simpl.
        rewrite stream_prefix_map.
        rewrite stream_prefix_nth; try assumption.
        reflexivity.
    Qed.

(** *** Protocol traces

Finally, we define [Trace] as a sum-type of its finite/infinite variants.
It inherits some previously introduced definitions, culminating with the
[protocol_trace].
*)

    Definition ptrace_from_prop (tr : Trace) : Prop :=
      match tr with
      | Finite s ls => finite_protocol_trace_from s ls
      | Infinite s sm => infinite_protocol_trace_from s sm
      end.

    Definition protocol_trace_prop (tr : Trace) : Prop :=
      match tr with
      | Finite s ls => finite_protocol_trace s ls
      | Infinite s sm => infinite_ptrace s sm
      end.

    Definition protocol_trace : Type :=
      { tr : Trace | protocol_trace_prop tr}.

    Lemma protocol_trace_from
      (tr : Trace)
      (Htr : protocol_trace_prop tr)
      : ptrace_from_prop tr.
    Proof.
      destruct tr; simpl; destruct Htr as [Htr Hinit]; assumption.
    Qed.

    Lemma protocol_trace_initial
      (tr : Trace)
      (Htr : protocol_trace_prop tr)
      : initial_state_prop (trace_first tr).
    Proof.
      destruct tr; simpl; destruct Htr as [Htr Hinit]; assumption.
    Qed.

    Lemma protocol_trace_from_iff
      (tr : Trace)
      : protocol_trace_prop tr
      <-> ptrace_from_prop tr /\ initial_state_prop (trace_first tr).
    Proof.
      split.
      - intro Htr; split.
        + apply protocol_trace_from; assumption.
        + apply protocol_trace_initial; assumption.
      - destruct tr; simpl; intros [Htr Hinit]; split; assumption.
    Qed.

    (* begin hide *)
    (* Protocol runs *)

    Inductive vlsm_run_prop : proto_run -> Prop :=
    | empty_run_initial_state
        (is : state)
        (His : initial_state_prop is)
      : vlsm_run_prop {| start := is; transitions := []; final := (is, None) |}
    | empty_run_initial_message
        (im : message)
        (Him : initial_message_prop im)
        (s : state)
        (Hs : initial_state_prop s)
      : vlsm_run_prop {| start := s; transitions := []; final := (s, Some im) |}
    | extend_run
        (state_run : proto_run)
        (Hs : vlsm_run_prop state_run)
        (s := fst (final state_run))
        (is := start state_run)
        (ts := transitions state_run)
        (msg_run : proto_run)
        (Hm : vlsm_run_prop msg_run)
        (om := snd (final msg_run))
        (l : label)
        (Hv : valid l (s, om))
        (som' := transition l (s, om))
      : vlsm_run_prop {| start := is; transitions := ts ++ [
          {|   l := l
          ;   input := om
          ;   destination := fst som'
          ;   output := snd som'
          |}]; final := som' |}.

    Lemma vlsm_run_initial_state
      (run : proto_run)
      (Hrun : vlsm_run_prop run)
      : initial_state_prop (start run).
    Proof.
      induction Hrun; [assumption| ..].
      - destruct s0. assumption.
      - unfold is in *. simpl. assumption.
    Qed.

    (** The output message of a vlsm_run with no transitions must be initial*)
    Lemma vlsm_run_no_transitions_output
      (run : proto_run)
      (Hrun : vlsm_run_prop run)
      (Hno_transitions : transitions run = [])
      (m : message)
      (Houtput : snd (final run) = Some m)
      : initial_message_prop m.
    Proof.
      destruct run. destruct final0. simpl in *.
      subst.
      inversion Hrun; subst; [assumption|].
      destruct ts; discriminate H1.
    Qed.

    Definition vlsm_run : Type :=
      { r : proto_run | vlsm_run_prop r }.

    Lemma vlsm_run_last_state
      (vr : vlsm_run)
      (r := proj1_sig vr)
      : finite_trace_last (start r) (transitions r) = fst (final r).
    Proof.
      unfold r; clear r; destruct vr as [r Hr]; simpl.
      induction Hr; simpl; try reflexivity.
      apply finite_trace_last_is_last.
    Qed.

    Lemma vlsm_run_last_final
      (vr : vlsm_run)
      (r := proj1_sig vr)
      (tr := transitions r)
      (Hne_tr : tr <> [])
      (lst := last_error tr)
      : option_map destination lst = Some (fst (final r))
      /\ option_map output lst = Some (snd (final r)).
    Proof.
      unfold r in *; clear r; destruct vr as [r Hr]; inversion Hr; subst; simpl in *; clear Hr
      ; try contradiction.
      unfold tr in *. unfold lst in *. rewrite last_error_is_last . simpl.
      split; reflexivity.
    Qed.

    Lemma run_is_protocol
          (vr : vlsm_run)
      : protocol_prop (final (proj1_sig vr)).
    Proof.
      destruct vr as [r Hr]; simpl.
      induction Hr; simpl in *.
      - replace is with (proj1_sig (exist _ is His)) by reflexivity.
        constructor. assumption. exact I.
      - apply protocol_initial;assumption.
      - unfold om in *; clear om. unfold s in *; clear s.
        destruct (final state_run) as [s _om].
        destruct (final msg_run) as [_s om].
        specialize (protocol_generated l1 s _om IHHr1 _s om IHHr2 Hv). intro. assumption.
    Qed.

    Lemma protocol_is_run
          (som' : state * option message)
          (Hp : protocol_prop som')
      : exists vr : vlsm_run, (som' = final (proj1_sig vr)).
    Proof.
      induction Hp.
      - destruct om as [m|].
        + exists (exist _ _ (empty_run_initial_message _ Hom _ Hs)); reflexivity.
        + exists (exist _ _ (empty_run_initial_state _ Hs)); reflexivity.
      - destruct IHHp1 as [[state_run Hsr] Heqs]. destruct IHHp2 as [[msg_run Hmr] Heqm].
        specialize (extend_run state_run Hsr). simpl. intros Hvr.
        specialize (Hvr msg_run Hmr l1). simpl in Heqs. simpl in Heqm.
        rewrite <- Heqs in Hvr. rewrite <- Heqm in Hvr. specialize (Hvr Hv).
        exists (exist _ _ Hvr). reflexivity.
    Qed.

    Lemma run_is_trace
          (vr : vlsm_run)
          (r := proj1_sig vr)
      : protocol_trace_prop (Finite (start r) (transitions r)).
    Proof.
      unfold r; clear r; destruct vr as [r Hr]; simpl.
      induction Hr; simpl.
      - split;[|assumption].
        constructor. apply initial_is_protocol; assumption.
      - split;[|assumption].
        constructor. apply initial_is_protocol. assumption.
      - destruct IHHr1 as [Htr Hinit].
        split; try assumption.
        apply extend_right_finite_trace_from; try assumption.
        specialize vlsm_run_last_state; intros Hls. specialize (Hls (exist _ state_run Hr1)).
        simpl in Hls. unfold ts. unfold is. rewrite Hls.
        repeat split; try assumption.
        + exists (snd (final state_run)). rewrite <- surjective_pairing.
          specialize (run_is_protocol (exist _ state_run Hr1)); intro Hp; assumption.
        + exists (fst (final msg_run)). rewrite <- surjective_pairing.
          specialize (run_is_protocol (exist _ msg_run Hr2)); simpl; intro Hp; assumption.
        + rewrite <- surjective_pairing. reflexivity.
    Qed.

    Lemma trace_is_run
      (is : state)
      (tr : list transition_item)
      (Htr : finite_protocol_trace is tr)
      : exists r : proto_run,
        vlsm_run_prop r /\
        start r = is /\ transitions r = tr.
    Proof.
      induction Htr using finite_protocol_trace_rev_ind.
      - exists {| start := si; transitions := []; final := (si, None) |}; simpl; repeat split; try reflexivity.
        apply empty_run_initial_state. assumption.
      - destruct Hx as [[_ [Hmsg Hvalid]] Htrans].
        destruct IHHtr as [r0 [Hr0 [Hstart Htr_r0]]].
        eexists {| final := (sf,oom)|};simpl;repeat split;[|reflexivity..].
        specialize (extend_run r0 Hr0); simpl; intros Hextend.
        replace (fst (final r0)) with (finite_trace_last si tr) in Hextend by
          (rewrite <- Hstart, <- Htr_r0;
          apply (vlsm_run_last_state (exist _ r0 Hr0))).
        rewrite Hstart, Htr_r0 in Hextend.
        clear Hstart Htr_r0.
        destruct Hmsg as [_s Hmsg].
        apply protocol_is_run in Hmsg as [[r_msg Hr_msg] Hmsg].
        apply (f_equal snd) in Hmsg; simpl in Hmsg.
        specialize (Hextend r_msg Hr_msg).
        rewrite <- Hmsg in Hextend.
        clear _s r_msg Hr_msg Hmsg.
        specialize (Hextend l1 Hvalid).
        rewrite Htrans in Hextend.
        assumption.
    Qed.

    Lemma trace_is_protocol_prop
      (is : state)
      (tr : list transition_item)
      (Htr : finite_protocol_trace is tr)
      : protocol_prop (finite_trace_last is tr, last (List.map output tr) None).
    Proof.
      specialize (trace_is_run is tr Htr); simpl; intro Hrun.
      destruct Hrun as [run [Hrun [Hstart Htrans]]].
      specialize (run_is_protocol (exist _ run Hrun)); simpl; intro Hps.
      specialize (vlsm_run_last_final (exist _ run Hrun)); simpl; intros Hlast'.
      rewrite Htrans in Hlast'.
      destruct_list_last tr tr' lst Heq.
      - clear Hlast'. subst. simpl. destruct Htr as [_ Hinit].
        change (start run) with (proj1_sig (exist _ _ Hinit)).
        apply protocol_initial_state.
        assumption.
      - spec Hlast'; [destruct tr'; intro contra; inversion contra|].
        rewrite! last_error_is_last in Hlast'. simpl in Hlast'.
        destruct Hlast' as [Hdestination Houtput].
        rewrite finite_trace_last_is_last.
        rewrite! map_app. simpl. rewrite! last_is_last.
        destruct (final run) as (s, om). simpl in *.
        congruence.
    Qed.

    Lemma trace_is_protocol_state
      (is : state)
      (tr : list transition_item)
      (Htr : finite_protocol_trace is tr)
      : protocol_state_prop (finite_trace_last is tr).
    Proof.
      eexists _. apply trace_is_protocol_prop. assumption.
    Qed.

        (* end hide *)

(** Having defined [protocol_trace]s, we now connect them to protocol states
and messages, in the following sense: for each state-message pair (<<s>>, <<m>>)
that has the [protocol_prop]erty, there exists a [protocol_trace] which ends
in <<s>> by outputting <<m>> *)

    Lemma protocol_is_trace
          (s : state)
          (om : option message)
          (Hp : protocol_prop (s, om))

      : initial_state_prop s
      \/ exists (is : state) (tr : list transition_item),
            finite_protocol_trace_init_to is s tr
            /\ option_map output (last_error tr) = Some om.
    Proof.
      specialize (protocol_is_run (s,om) Hp); intros [vr Heq].
      specialize (run_is_trace vr); simpl; intros Htr.
      destruct vr as [r Hvr]; simpl in *.
      destruct (transitions r) eqn:Htrace.
      - inversion Hvr; subst; simpl in Htrace; simpl in Heq; inversion Heq; subst.
        + left. assumption.
        + destruct s0 as [s0 His]. left. assumption.
        + destruct ts; inversion Htrace.
      - right. exists (start r). exists (transitions r). rewrite Htrace.
        specialize (vlsm_run_last_final (exist _ r Hvr)).
        simpl; rewrite <- Heq; simpl; rewrite Htrace.
        intros [Hs Hom];[discriminate|].
        split;[|assumption].
        apply finite_protocol_trace_init_add_last;
        [|apply last_error_destination_last];assumption.
    Qed.

    (** Giving a trace for [protocol_state_prop] can be stated more
        simply than [protocol_is_trace], because we don't need a
        disjunction because we are not making claims about [output]
        messages.
     *)
    Lemma protocol_state_has_trace
          (s : state)
          (Hp : protocol_state_prop s):
      exists (is : state) (tr : list transition_item),
        finite_protocol_trace_init_to is s tr.
    Proof using.
      destruct Hp as [_om Hp].
      apply protocol_is_trace in Hp.
      destruct Hp as [Hinit|Htrace].
      + exists s, [].
        split;[|assumption].
        constructor.
        apply initial_is_protocol.
        assumption.
      + destruct Htrace as [is [tr [Htr _]]].
        exists is, tr.
        assumption.
    Qed.

    (** Any trace with the 'finite_protocol_trace_from' property can be completed
    (to the left) to start in an initial state*)
    Lemma finite_protocol_trace_from_complete_left
      (s : state)
      (tr : list transition_item)
      (Htr : finite_protocol_trace_from s tr)
      : exists (is : state) (trs : list transition_item),
        finite_protocol_trace is (trs ++ tr) /\
        finite_trace_last is trs = s.
    Proof.
      apply finite_ptrace_first_pstate in Htr as Hs.
      apply protocol_state_has_trace in Hs.
      destruct Hs as [is [trs [Htrs His]]].
      exists is, trs.
      apply finite_protocol_trace_from_to_last in Htrs as Hlast.
      rewrite <- Hlast in Htr.
      apply finite_protocol_trace_from_to_forget_last in Htrs.
      repeat (split || assumption ||
      apply finite_protocol_trace_from_app_iff).
    Qed.

    (** Any trace with the 'finite_protocol_trace_from_to' property can be completed
    (to the left) to start in an initial state*)
    Lemma finite_protocol_trace_from_to_complete_left
      (s f : state)
      (tr : list transition_item)
      (Htr : finite_protocol_trace_from_to s f tr)
      : exists (is : state) (trs : list transition_item),
        finite_protocol_trace_init_to is f (trs ++ tr) /\
        finite_trace_last is trs = s.
    Proof.
      assert (protocol_state_prop s) as Hs
        by (apply finite_protocol_trace_from_to_forget_last,
            finite_ptrace_first_pstate in Htr; assumption).
      apply protocol_state_has_trace in Hs.
      destruct Hs as [is [trs [Htrs His]]].
      exists is, trs.
      split.
      - split;[|assumption].
        apply finite_protocol_trace_from_to_app with s;assumption.
      - apply finite_protocol_trace_from_to_last in Htrs;assumption.
    Qed.

(** Another benefit of defining traces is that we can succintly
describe indirect transitions between arbitrary pairs of states.

We say that state <<second>> is in state <<first>>'s futures if
there exists a finite (possibly empty) protocol trace that begins
with <<first>> and ends in <<second>>.

This relation is often used in stating safety and liveness properties.*)

    Definition in_futures
      (first second : state)
      : Prop :=
      exists (tr : list transition_item),
        finite_protocol_trace_from_to first second tr.

    Lemma in_futures_preserving
      (R : state -> state -> Prop)
      (Hpre : PreOrder R)
      (Ht : protocol_transition_preserving R)
      (s1 s2 : state)
      (Hin : in_futures s1 s2)
      : R s1 s2.
    Proof.
      unfold in_futures in Hin.
      destruct Hin as [tr Htr].
      induction Htr.
      - reflexivity.
      - apply Ht in H.
        transitivity s;assumption.
    Qed.

    Instance eq_equiv : @Equivalence state eq := _.

    Lemma in_futures_strict_preserving
      (R : state -> state -> Prop)
      (Hpre : StrictOrder R)
      (Ht : protocol_transition_preserving R)
      (s1 s2 : state)
      (Hin : in_futures s1 s2)
      (Hneq : s1 <> s2)
      : R s1 s2.
    Proof.
      apply (StrictOrder_PreOrder eq_equiv) in Hpre.
      - specialize (in_futures_preserving (relation_disjunction R eq) Hpre) as Hpreserve.
        spec Hpreserve.
        + intro; intros. left. apply (Ht s3 s4 l1 om1 om2 Hprotocol).
        + spec Hpreserve s1 s2 Hin. destruct Hpreserve; try assumption.
          elim Hneq. assumption.
      - intros x1 x2 Heq. subst. intros y1 y2 Heq. subst.
        split; intro; assumption.
    Qed.

    Lemma in_futures_protocol_fst
      (first second : state)
      (Hfuture: in_futures first second)
      : protocol_state_prop first.
    Proof.
      destruct Hfuture as [tr Htr].
      apply finite_protocol_trace_from_to_forget_last in Htr.
      apply finite_ptrace_first_pstate in Htr.
      assumption.
    Qed.

    (* begin hide *)

    Lemma in_futures_refl
      (first: state)
      (Hps : protocol_state_prop first)
      : in_futures first first.

    Proof.
      exists [].
      constructor.
      assumption.
    Qed.

    Lemma in_futures_trans
      (first second third : state)
      (H12: in_futures first second)
      (H23 : in_futures second third)
      : in_futures first third.
    Proof.
      destruct H12 as [tr12 Htr12].
      destruct H23 as [tr23 Htr23].
      exists (tr12 ++ tr23).
      apply finite_protocol_trace_from_to_app with second;assumption.
    Qed.

    Lemma in_futures_witness
      (first second : state)
      (Hfutures : in_futures first second)
      : exists (tr : protocol_trace) (n1 n2 : nat),
        n1 <= n2
        /\ trace_nth (proj1_sig tr) n1 = Some first
        /\ trace_nth (proj1_sig tr) n2 = Some second.
    Proof.
      specialize (in_futures_protocol_fst first second Hfutures); intro Hps.
      apply protocol_state_has_trace in Hps.
      destruct Hps as [prefix_start [prefix_tr [Hprefix_tr Hinit]]].
      destruct Hfutures as [suffix_tr Hsuffix_tr].
      specialize (finite_protocol_trace_from_to_app _ _ _ _ _ Hprefix_tr Hsuffix_tr) as Happ.
      apply finite_protocol_trace_from_to_forget_last in Happ.
      assert (Htr : protocol_trace_prop (Finite prefix_start (prefix_tr ++ suffix_tr)))
        by (split;assumption).
      exists (exist _ _ Htr).
      simpl.
      exists (length prefix_tr), (length prefix_tr + length suffix_tr).
      split;[lia|].
      apply finite_protocol_trace_from_to_last in Hprefix_tr.
      apply finite_protocol_trace_from_to_last in Hsuffix_tr.
      split.
      - rewrite finite_trace_nth_app1;[|lia].
        rewrite finite_trace_nth_last.
        congruence.
      - rewrite finite_trace_nth_app2;[|lia].
        rewrite Minus.minus_plus.
        rewrite finite_trace_nth_last.
        congruence.
    Qed.

    Definition trace_segment
      (tr : Trace)
      (n1 n2 : nat)
      : list transition_item
      := match tr with
      | Finite s l => list_segment l n1 n2
      | Infinite s l => stream_segment l n1 n2
      end.

    Lemma ptrace_segment
      (tr : Trace)
      (Htr : protocol_trace_prop tr)
      (n1 n2 : nat)
      (Hle : n1 <= n2)
      (first : state)
      (Hfirst : trace_nth tr n1 = Some first)
      : finite_protocol_trace_from first (trace_segment tr n1 n2).
    Proof.
      destruct tr as [s tr | s tr]; simpl in *; destruct Htr as [Htr Hinit].
      - apply finite_protocol_trace_from_segment with s; try assumption.
      - inversion Hfirst; subst; clear Hfirst.
        apply (infinite_protocol_trace_from_segment s tr Htr n1 n2 Hle).
    Qed.

    Inductive Trace_messages : Type :=
    | Finite_messages : list (option message) -> Trace_messages
    | Infinite_messages : Stream (option message) -> Trace_messages.

    Definition protocol_output_messages_trace (tr : protocol_trace) : Trace_messages :=
      match proj1_sig tr with
      | Finite _ ls => Finite_messages (List.map output ls)
      | Infinite _ st => Infinite_messages (map output st) end.

    Definition protocol_input_messages_trace (tr : protocol_trace) : Trace_messages :=
      match proj1_sig tr with
      | Finite _ ls => Finite_messages (List.map input ls)
      | Infinite _ st => Infinite_messages (map input st) end.

    Definition trace_prefix
               (tr : Trace)
               (last : transition_item)
               (prefix : list transition_item)
      :=
        match tr with
        | Finite s ls => exists suffix, ls = prefix ++ (last :: suffix)
        | Infinite s st => exists suffix, st = stream_app prefix (Cons last suffix)
        end.

    Definition trace_prefix_fn
      (tr : Trace)
      (n : nat)
      : Trace
      :=
      match tr with
      | Finite s ls => Finite s (list_prefix ls n)
      | Infinite s st => Finite s (stream_prefix st n)
      end.

    Lemma trace_prefix_protocol
          (tr : protocol_trace)
          (last : transition_item)
          (prefix : list transition_item)
          (Hprefix : trace_prefix (proj1_sig tr) last prefix)
      : protocol_trace_prop (Finite (trace_first (proj1_sig tr)) (prefix ++ [last])).
    Proof.
      destruct tr as [tr Htr]. simpl in *.
      generalize dependent tr. generalize dependent last.
      apply (rev_ind (fun prefix => forall (last : transition_item) (tr : Trace), protocol_trace_prop tr -> trace_prefix tr last prefix -> finite_protocol_trace (trace_first tr) (prefix ++ [last]))).
      - intros last tr Htr Hprefix; destruct tr as [ | ]; unfold trace_prefix in Hprefix;   simpl in Hprefix
        ; destruct Hprefix as [suffix Heq]; subst; destruct Htr as [Htr Hinit]
        ; unfold trace_first; simpl; constructor; try assumption
        ; inversion Htr; subst; clear Htr
        ; apply finite_ptrace_singleton; assumption.
      - intros last_p p Hind last tr Htr Hprefix.
        specialize (Hind last_p tr Htr).
        destruct tr as [ | ]; unfold trace_prefix in Hprefix;   simpl in Hprefix
        ; destruct Hprefix as [suffix Heq]; subst; destruct Htr as [Htr Hinit]; simpl; simpl in Hind
        ; split; try assumption
        .
        + assert
            (Hex : exists suffix0 : list transition_item,
                (p ++ [last_p]) ++ last :: suffix = p ++ last_p :: suffix0
            ) by (exists (last :: suffix); rewrite <- app_assoc; reflexivity)
          ; specialize (Hind Hex); clear Hex
          ; destruct Hind as [Hptr _]
          ; destruct last
          ; apply extend_right_finite_trace_from
          ; try assumption
          .
          rewrite <- (app_cons {| l := l1; input := input0; destination := destination0; output := output0 |} suffix) in Htr.
          rewrite app_assoc in Htr.
          rewrite <- (app_assoc p _ _) in Htr. simpl in Htr.
          rewrite <- app_assoc in Htr.
          specialize
            (finite_ptrace_consecutive_valid_transition _ _ _ _ _ _ Htr eq_refl).
          simpl.
          rewrite finite_trace_last_is_last. trivial.
        + assert
            (Hex : exists suffix0 : Stream transition_item,
                stream_app (p ++ [last_p])  (Cons last suffix) = stream_app p (Cons last_p suffix0)
            ) by (exists (Cons last suffix); rewrite <- stream_app_assoc; reflexivity)
          ; specialize (Hind Hex); clear Hex
          ; destruct Hind as [Hptr _]
          ; destruct last
          ; apply extend_right_finite_trace_from
          ; try assumption
          .
          rewrite <- stream_app_cons in Htr.
          rewrite stream_app_assoc in Htr.
          rewrite <- (app_assoc p _ _) in Htr. simpl in Htr.
          specialize
            (infinite_ptrace_consecutive_valid_transition
               s
               (stream_app (p ++ [last_p; {| l := l1; input := input0; destination := destination0; output := output0 |}]) suffix)
               suffix
               p
               last_p
               {| l := l1; input := input0; destination := destination0; output := output0 |}
               Htr
               eq_refl
            ).
          simpl.
          rewrite finite_trace_last_is_last. trivial.
    Qed.

    Definition build_trace_prefix_protocol
          {tr : protocol_trace}
          {last : transition_item}
          {prefix : list transition_item}
          (Hprefix : trace_prefix (proj1_sig tr) last prefix)
          : protocol_trace
      := exist _ (Finite (trace_first (proj1_sig tr)) (prefix ++ [last]))
               (trace_prefix_protocol tr last prefix Hprefix).

    Lemma trace_prefix_fn_protocol
          (tr : Trace)
          (Htr : protocol_trace_prop tr)
          (n : nat)
      : protocol_trace_prop (trace_prefix_fn tr n).
    Proof.
      specialize (trace_prefix_protocol (exist _ tr Htr)); simpl; intro Hpref.
      remember (trace_prefix_fn tr n) as pref_tr.
      destruct pref_tr as [s l | s l].
      - destruct l as [| item l].
        + destruct tr as [s' l' | s' l']
          ; destruct Htr as [Htr Hinit]
          ; inversion Heqpref_tr; subst
          ; (split;[|assumption])
          ; constructor
          ;  apply initial_is_protocol;assumption.
        + assert (Hnnil : item ::l <> [])
            by (intro Hnil; inversion Hnil).
          specialize (exists_last Hnnil); intros [prefix [last Heq]].
          rewrite Heq in *; clear Hnnil Heq l item.
          replace s with (trace_first (proj1_sig (exist _ tr Htr)))
          ; try (destruct tr; inversion Heqpref_tr; subst; reflexivity).
          apply trace_prefix_protocol.
          destruct tr as [s' l' | s' l']
          ; inversion Heqpref_tr
          ; subst
          ; clear Heqpref_tr
          ; simpl.
          * specialize (list_prefix_suffix l' n); intro Hl'.
            rewrite <- Hl'. rewrite <- H1.
            exists (list_suffix l' n).
            rewrite <- app_assoc.
            reflexivity.
          * specialize (stream_prefix_suffix l' n); intro Hl'.
            rewrite <- Hl'. rewrite <- H1.
            exists (stream_suffix l' n).
            rewrite <- stream_app_assoc.
            reflexivity.
      - destruct tr as [s' l' | s' l']; inversion Heqpref_tr.
    Qed.

    Lemma protocol_trace_nth
      (tr : Trace)
      (Htr : protocol_trace_prop tr)
      (n : nat)
      (s : state)
      (Hnth : trace_nth tr n = Some s)
      : protocol_state_prop s.
    Proof.
      destruct tr as [s0 l | s0 l]; destruct Htr as [Htr Hinit].
      - specialize (finite_protocol_trace_from_suffix s0 l Htr n s Hnth).
        intro Hsuf.
        apply finite_ptrace_first_pstate in Hsuf.
        assumption.
      - assert (Hle : n <= n) by lia.
        specialize (infinite_protocol_trace_from_segment s0 l Htr n n Hle)
        ; simpl; intros Hseg.
        inversion Hnth.
        apply finite_ptrace_first_pstate in Hseg.
        assumption.
    Qed.

    Lemma in_futures_protocol_snd
      (first second : state)
      (Hfutures: in_futures first second)
      : protocol_state_prop second.
    Proof.
      specialize (in_futures_witness first second Hfutures)
      ; intros [tr [n1 [n2 [Hle [Hn1 Hn2]]]]].
      destruct tr as [tr Htr]; simpl in Hn2.
      apply protocol_trace_nth with tr n2; assumption.
    Qed.

    Lemma in_futures_witness_reverse
      (first second : state)
      (tr : protocol_trace)
      (n1 n2 : nat)
      (Hle : n1 <= n2)
      (Hs1 : trace_nth (proj1_sig tr) n1 = Some first)
      (Hs2 : trace_nth (proj1_sig tr) n2 = Some second)
      : in_futures first second.
    Proof.
      destruct tr as [tr Htr].
      simpl in *.
      inversion Hle; subst; clear Hle.
      - rewrite Hs1 in Hs2. inversion Hs2; subst; clear Hs2.
        exists [].
        constructor. apply protocol_trace_nth with tr n2; assumption.
      - exists (trace_segment tr n1 (S m)).
        apply finite_protocol_trace_from_add_last.
        + apply ptrace_segment; try assumption. lia.
        + { destruct tr as [s tr | s tr]; simpl.
          - simpl in Hs1, Hs2.
            unfold list_segment.
            rewrite finite_trace_last_suffix.
            apply finite_trace_last_prefix. assumption.
            rewrite list_prefix_length. lia.
            apply finite_trace_nth_length in Hs2. lia.
          - unfold stream_segment.
            rewrite unlock_finite_trace_last.
            rewrite list_suffix_map, stream_prefix_map.
            simpl in Hs2.
            rewrite list_suffix_last.
            + symmetry. rewrite stream_prefix_nth_last.
              unfold Str_nth in Hs2. simpl in Hs2.
              inversion Hs2; subst.
              reflexivity.
            + specialize (stream_prefix_length (Streams.map destination tr) (S m)); intro Hpref_len.
              rewrite Hpref_len.
              lia.
          }
    Qed.
    (* end hide *)

(**
Stating livness properties will require quantifying over complete
executions of the protocol. To make this possible, we will now define
_complete_ [protocol_trace]s.

A [protocol_trace] is _terminating_ if there's no other [protocol_trace]
that contains it as a prefix.
*)

    Definition terminating_trace_prop (tr : Trace) : Prop
       :=
         match tr with
         | Finite s ls =>
             (exists (tr : protocol_trace)
             (last : transition_item),
             trace_prefix (proj1_sig tr) last ls) -> False
         | Infinite s ls => False
         end.

(** A [protocol_trace] is _complete_, if it is either _terminating_ or infinite.
*)

    Definition complete_trace_prop (tr : Trace) : Prop
       := protocol_trace_prop tr
          /\
          match tr with
          | Finite _ _ => terminating_trace_prop tr
          | Infinite _ _ => True
          end.

    (* begin hide *)

    (* Implicitly, the state itself must be in the trace, and minimally the last element of the trace *)
    (* Also implicitly, the trace leading up to the state is finite *)
    (* Defining equivocation on these trace definitions *)

    (* Section 7 :
       A message m received by a protocol state s with a transition label l in a
       protocol execution trace is called "an equivocation" if it wasn't produced
       in that trace
    *)

    (* 6.2.2 Equivocation-free as a composition constraint *)
    Definition composition_constraint : Type :=
      label -> state * option message -> Prop.

    (* Decidable VLSMs *)

    Class VLSM_vdecidable :=
      { valid_decidable : forall l som, {valid l som} + {~valid l som}
      }.
(* end hide *)
End VLSM.

(** Make all arguments of [protocol_state_prop_ind] explicit
    so it will work with the <<induction using>> tactic.
    (closing the section added <<{message}>> as an implicit argument)
 *)
Arguments protocol_state_prop_ind : clear implicits.
Arguments finite_protocol_trace_from_to_ind : clear implicits.

Arguments finite_protocol_trace_rev_ind : clear implicits.
Arguments finite_protocol_trace_from_rev_ind : clear implicits.

Arguments extend_right_finite_trace_from [message] (X) [s1] [ts] (Ht12) [l3] [iom3] [s3] [oom3] (Hv23).
Arguments extend_right_finite_trace_from_to [message] (X) [s1] [s2] [ts] (Ht12) [l3] [iom3] [s3] [oom3] (Hv23).

Class TraceWithLast
      (base_prop : forall {message} (X: VLSM message),
      @state _ (@type _ X) -> list transition_item -> Prop)
      (trace_prop : forall {message} (X: VLSM message),
        state -> state -> list transition_item -> Prop) :=
  {ptrace_add_last: forall [msg] [X: VLSM msg] [s f tr],
     base_prop X s tr -> finite_trace_last s tr = f -> trace_prop X s f tr;
   ptrace_get_last: forall [msg] [X: VLSM msg] [s f tr],
     trace_prop X s f tr -> finite_trace_last s tr = f;
   ptrace_last_pstate: forall [msg] [X: VLSM msg] [s f tr],
     trace_prop X s f tr -> protocol_state_prop X f;
   ptrace_forget_last: forall [msg] [X: VLSM msg] [s f tr],
     trace_prop X s f tr -> base_prop X s tr
  }.
Hint Mode TraceWithLast - ! : typeclass_instances.
Hint Mode TraceWithLast ! - : typeclass_instances.

Definition ptrace_add_default_last
  `{TraceWithLast base_prop trace_prop}
  [msg] [X:VLSM msg] [s tr] (Htr: base_prop msg X s tr):
    trace_prop msg X s (finite_trace_last s tr) tr.
Proof.
  apply ptrace_add_last. assumption. reflexivity.
Defined.

Instance trace_with_last_ptrace_from:
  TraceWithLast (@finite_protocol_trace_from) (@finite_protocol_trace_from_to)
  := {ptrace_add_last := @finite_protocol_trace_from_add_last;
      ptrace_get_last := @finite_protocol_trace_from_to_last;
      ptrace_last_pstate := @finite_protocol_trace_from_to_last_pstate;
      ptrace_forget_last := @finite_protocol_trace_from_to_forget_last;
     }.

Instance trace_with_last_ptrace_init:
  TraceWithLast (@finite_protocol_trace) (@finite_protocol_trace_init_to)
  := {ptrace_add_last := @finite_protocol_trace_init_add_last;
      ptrace_get_last := @finite_protocol_trace_init_to_last;
      ptrace_last_pstate _ _ _ _ _ H := ptrace_last_pstate (proj1 H);
      ptrace_forget_last := @finite_protocol_trace_init_to_forget_last;
     }.

Class TraceWithStart
     {message} {X : VLSM message}
     (start : @state message (type X))
     (trace_prop : list (transition_item (type X)) -> Prop) :=
 {ptrace_first_pstate:
    forall [tr], trace_prop tr -> protocol_state_prop X start
 }.
Hint Mode TraceWithStart - - - ! : typeclass_instances.

Instance trace_with_start_ptrace_from message (X: VLSM message) s:
  TraceWithStart s (finite_protocol_trace_from X s)
  := {ptrace_first_pstate := finite_ptrace_first_pstate X s}.
Instance trace_with_start_ptrace message (X: VLSM message) s:
  TraceWithStart s (finite_protocol_trace X s)
  := {ptrace_first_pstate tr H := ptrace_first_pstate (proj1 H)}.
Instance trace_with_start_ptrace_from_to message (X: VLSM message) s f:
  TraceWithStart s (finite_protocol_trace_from_to X s f)
  := {ptrace_first_pstate tr H := ptrace_first_pstate (ptrace_forget_last H)}.
Instance trace_with_start_ptrace_init_to message (X: VLSM message) s f:
  TraceWithStart s (finite_protocol_trace_init_to X s f)
  := {ptrace_first_pstate tr H := ptrace_first_pstate (ptrace_forget_last H)}.

(** *** VLSM Inclusion and Equality

We can also define VLSM _inclusion_  and _equality_ in terms of traces.
When both VLSMs have the same state and label types they also share the
same [Trace] type, and sets of traces can be compared without conversion.
- VLSM X is _included_ in VLSM Y if every [protocol_trace] available to X
is also available to Y.
- VLSM X and VLSM Y are _equal_ if their [protocol_trace]s are exactly the same.
*)

  Section VLSM_equality.
    Context
      {message : Type}
      {vtype : VLSM_type message}
      .

    Definition VLSM_eq_part
      {SigX SigY: VLSM_sign vtype}
      (MX : VLSM_class SigX) (MY : VLSM_class SigY)
      (X := mk_vlsm MX) (Y := mk_vlsm MY)
      :=
      forall t : Trace,
        protocol_trace_prop X t <-> protocol_trace_prop Y t .
    Local Notation VLSM_eq X Y := (VLSM_eq_part (machine X) (machine Y)).

    Definition VLSM_incl_part
      {SigX SigY: VLSM_sign vtype}
      (MX : VLSM_class SigX) (MY : VLSM_class SigY)
      (X := mk_vlsm MX) (Y := mk_vlsm MY)
      :=
      forall t : Trace,
        protocol_trace_prop X t -> protocol_trace_prop Y t.
    Local Notation VLSM_incl X Y := (VLSM_incl_part (machine X) (machine Y)).

    Lemma VLSM_incl_trans
      {SigX SigY SigZ: VLSM_sign vtype}
      (MX : VLSM_class SigX) (MY : VLSM_class SigY) (MZ : VLSM_class SigZ)
      (X := mk_vlsm MX) (Y := mk_vlsm MY) (Z := mk_vlsm MZ)
      : VLSM_incl X Y -> VLSM_incl Y Z -> VLSM_incl X Z.
    Proof.
      firstorder.
    Qed.

    Lemma VLSM_incl_in_futures
      {SigX SigY: VLSM_sign vtype}
      (MX : VLSM_class SigX) (MY : VLSM_class SigY)
      (X := mk_vlsm MX) (Y := mk_vlsm MY)
      (Hincl : VLSM_incl X Y)
      (s1 s2 : vstate X)
      : in_futures X s1 s2 -> in_futures Y s1 s2.
    Proof.
      intro Hfuture.
      apply in_futures_witness in Hfuture.
      destruct Hfuture as [[tr Htr] [n1 [n2 [Hle [Hs1 Hs2]]]]].
      simpl in Hs1. simpl in Hs2.
      apply Hincl in Htr.
      apply (in_futures_witness_reverse Y s1 s2 (exist _ tr Htr) n1 n2 Hle Hs1 Hs2).
    Qed.

    (* begin hide *)

    Lemma VLSM_eq_incl_l
      {SigX SigY: VLSM_sign vtype}
      (MX : VLSM_class SigX) (MY : VLSM_class SigY)
      (X := mk_vlsm MX) (Y := mk_vlsm MY)
      : VLSM_eq X Y -> VLSM_incl X Y.
    Proof.
      intro Heq.
      intros t Hxt.
      apply Heq.
      assumption.
    Qed.

    Lemma VLSM_eq_incl_r
      {SigX SigY: VLSM_sign vtype}
      (MX : VLSM_class SigX) (MY : VLSM_class SigY)
      (X := mk_vlsm MX) (Y := mk_vlsm MY)
      : VLSM_eq X Y -> VLSM_incl Y X.
    Proof.
      intro Heq.
      intros t Hyt.
      apply Heq.
      assumption.
    Qed.

    Lemma VLSM_eq_incl_iff
      {SigX SigY: VLSM_sign vtype}
      (MX : VLSM_class SigX) (MY : VLSM_class SigY)
      (X := mk_vlsm MX) (Y := mk_vlsm MY)
      : VLSM_eq X Y <-> VLSM_incl X Y /\ VLSM_incl Y X.
    Proof.
      split.
      - intro Heq.
        split.
        + apply VLSM_eq_incl_l; assumption.
        + apply VLSM_eq_incl_r; assumption.
      - intros [Hxy Hyx].
        intro t.
        split.
        + apply Hxy.
        + apply Hyx.
    Qed.

    (** VLSM inclusion specialized to finite trace. *)

    Lemma VLSM_incl_finite_protocol_trace
      {SigX SigY: VLSM_sign vtype}
      (MX : VLSM_class SigX) (MY : VLSM_class SigY)
      (Hincl : VLSM_incl_part MX MY)
      (X := mk_vlsm MX) (Y := mk_vlsm MY)
      (s : vstate X)
      (tr : list (vtransition_item X))
      (Htr : finite_protocol_trace X s tr)
      : finite_protocol_trace Y s tr.
    Proof.
      assert (Hptr : protocol_trace_prop X (Finite s tr)) by assumption.
      cut (protocol_trace_prop Y (Finite s tr)). { intro. assumption. }
      revert Hptr. apply Hincl.
    Qed.

    Lemma VLSM_incl_finite_protocol_trace_init_to
      {SigX SigY: VLSM_sign vtype}
      (MX : VLSM_class SigX) (MY : VLSM_class SigY)
      (Hincl : VLSM_incl_part MX MY)
      (X := mk_vlsm MX) (Y := mk_vlsm MY)
      (s f : vstate X)
      (tr : list (vtransition_item X))
      (Htr : finite_protocol_trace_init_to X s f tr)
      : finite_protocol_trace_init_to Y s f tr.
    Proof.
      apply ptrace_add_last;
      [|apply ptrace_get_last in Htr;assumption].
      apply ptrace_forget_last in Htr.
      apply VLSM_incl_finite_protocol_trace;assumption.
    Qed.

    Lemma VLSM_incl_protocol_state
      {SigX SigY: VLSM_sign vtype}
      (MX : VLSM_class SigX) (MY : VLSM_class SigY)
      (Hincl : VLSM_incl_part MX MY)
      (X := mk_vlsm MX) (Y := mk_vlsm MY)
      (s : vstate X)
      (Hs : protocol_state_prop X s)
      : protocol_state_prop Y s.
    Proof.
      apply protocol_state_has_trace in Hs.
      destruct Hs as [is [tr Htr]].
      rewrite <- (ptrace_get_last Htr).
      apply ptrace_forget_last in Htr.
      apply (VLSM_incl_finite_protocol_trace _ MY) in Htr
      ; [|assumption].
      apply trace_is_protocol_state in Htr.
      simpl in *.
      assumption.
    Qed.

    Lemma VLSM_incl_initial_state
      {SigX SigY: VLSM_sign vtype}
      (MX : VLSM_class SigX) (MY : VLSM_class SigY)
      (Hincl : VLSM_incl_part MX MY)
      (X := mk_vlsm MX) (Y := mk_vlsm MY)
      (is : vstate X)
      : vinitial_state_prop X is -> vinitial_state_prop Y is.
    Proof.
      intro His.
      cut (finite_protocol_trace Y is []). { intro Hpis. apply Hpis. }
      assert (Hpis : finite_protocol_trace X is []).
      { split; [|assumption]. constructor. apply initial_is_protocol. assumption. }
      revert Hpis. apply VLSM_incl_finite_protocol_trace. assumption.
    Qed.

    Lemma VLSM_incl_finite_protocol_trace_from
      {SigX SigY: VLSM_sign vtype}
      (MX : VLSM_class SigX) (MY : VLSM_class SigY)
      (Hincl : VLSM_incl_part MX MY)
      (X := mk_vlsm MX) (Y := mk_vlsm MY)
      (s : vstate X)
      (tr : list (vtransition_item X))
      (Htr : finite_protocol_trace_from X s tr)
      : finite_protocol_trace_from Y s tr.
    Proof.
      apply finite_protocol_trace_from_complete_left in Htr.
      destruct Htr as [is [pre [Htr Hlst]]].
      apply (VLSM_incl_finite_protocol_trace _ MY) in Htr; [|assumption].
      destruct Htr as [Htr _].
      apply (finite_protocol_trace_from_app_iff Y) in Htr.
      apply proj2 in Htr. subst. assumption.
    Qed.

    Lemma VLSM_incl_finite_protocol_trace_from_to
      {SigX SigY: VLSM_sign vtype}
      (MX : VLSM_class SigX) (MY : VLSM_class SigY)
      (Hincl : VLSM_incl_part MX MY)
      (X := mk_vlsm MX) (Y := mk_vlsm MY)
      (s f : vstate X)
      (tr : list (vtransition_item X))
      (Htr : finite_protocol_trace_from_to X s f tr)
      : finite_protocol_trace_from_to Y s f tr.
    Proof.
      apply finite_protocol_trace_from_to_last in Htr as Hf.
      apply finite_protocol_trace_from_to_forget_last in Htr.
      apply (VLSM_incl_finite_protocol_trace_from _ MY) in Htr.
      apply finite_protocol_trace_from_add_last;assumption.
      assumption.
    Qed.

    Lemma VLSM_incl_protocol_transition
      {SigX SigY: VLSM_sign vtype}
      (MX : VLSM_class SigX) (MY : VLSM_class SigY)
      (Hincl : VLSM_incl_part MX MY)
      (X := mk_vlsm MX) (Y := mk_vlsm MY):
      forall l s im s' om,
      protocol_transition X l (s,im) (s',om) ->
      protocol_transition Y l (s,im) (s',om).
    Proof.
      intros l s im s' om Hstep.
      assert (protocol_state_prop X s) as Hs by apply Hstep.
      apply protocol_state_has_trace in Hs.
      destruct Hs as [is [tr [Htr Hinit]]].
      assert (protocol_trace_prop X (Finite is (tr ++ [{| l := l; input := im; destination := s'; output := om |}]))) as Htr'.
      {
        simpl.
        split;[|assumption].
        pose proof (extend_right_finite_trace_from_to X Htr Hstep) as Htr''.
        apply ptrace_forget_last in Htr'';assumption.
      }
      apply Hincl in Htr'.
      destruct Htr' as [Htrace _].
      apply (finite_protocol_trace_from_app_iff Y is tr) in Htrace as [_ Htrace].
      rewrite <- (ptrace_get_last Htr).
      inversion Htrace;assumption.
    Qed.

  (* end hide *)
  End VLSM_equality.

Notation VLSM_eq X Y := (VLSM_eq_part (machine X) (machine Y)).
Notation VLSM_incl X Y := (VLSM_incl_part (machine X) (machine Y)).

Lemma VLSM_eq_sym
  {message : Type}
  {vtype : VLSM_type message}
  {SigX SigY: VLSM_sign vtype}
  (MX : VLSM_class SigX) (MY : VLSM_class SigY)
  (X := mk_vlsm MX) (Y := mk_vlsm MY)
  : VLSM_eq X Y -> VLSM_eq Y X.
Proof.
  firstorder.
Qed.

Lemma VLSM_eq_trans
  {message : Type}
  {vtype : VLSM_type message}
  {SigX SigY SigZ: VLSM_sign vtype}
  (MX : VLSM_class SigX) (MY : VLSM_class SigY) (MZ : VLSM_class SigZ)
  (X := mk_vlsm MX) (Y := mk_vlsm MY) (Z := mk_vlsm MZ)
  : VLSM_eq X Y -> VLSM_eq Y Z -> VLSM_eq X Z.
Proof.
  firstorder.
Qed.

(**
  [VLSM_incl] almost implies inclusion of the [protocol_prop] sets.
  Some additional hypotheses are required because [VLSM_incl] only
  refers to traces, and [protocol_initial] means that
  [protocol_prop] includes some pairs that do not appear in any
  transition.
 *)
Lemma protocol_prop_incl
      [message : Type] [vtype : VLSM_type message] [SigX SigY : VLSM_sign vtype]
      (MX : VLSM_class SigX) (MY : VLSM_class SigY)
      (X := mk_vlsm MX)
      (Y := mk_vlsm MY):
  VLSM_incl X Y ->
  (forall m, vinitial_message_prop X m -> vinitial_message_prop Y m) ->
  forall som, protocol_prop X som -> protocol_prop Y som.
Proof.
  intros Hincl Hinits.
  induction 1.
  - (* protocol_initial *)
    cut (vinitial_state_prop Y s).
    {
      intro Hs'.
      simpl;apply protocol_initial.
      assumption.
      destruct om;[apply Hinits|];assumption.
    }
    assert (protocol_trace_prop X (Finite s [])).
    {
      simpl;unfold finite_protocol_trace.
      split;[|assumption].
      constructor;apply initial_is_protocol;assumption.
    }
    apply Hincl in H.
    apply H.
  - (* protocol_generated *)
    remember (transition l1 (s,om)) as som'.
    assert (protocol_transition X l1 (s,om) som').
    split. split. eexists;eassumption. split. eexists;eassumption. assumption.
    symmetry;assumption.
    destruct som' as [s' om'].
    apply (VLSM_incl_protocol_transition _ _ Hincl) in H1.
    destruct (id H1) as [Hvalid Heq].
    cbn in Heq |- *.
    rewrite <- Heq.
    eapply protocol_generated;[eassumption..|].
    apply Hvalid.
Qed.

(** It is natural to look for sufficient conditions for VLSM inclusion (or equality),
which are easy to verify in a practical setting. One such result is the following.

For VLSM <<X>> to be included in VLSM <<Y>>, the following set of conditions is sufficient:
- <<X>>'s [initial_state]s are included in <<Y>>'s [initial state]s
- Every message <<m>> (including the empty one) which can be input to a
[protocol_valid] transition in <<X>>, is a [protocol_message] in <<Y>>
- <<X>>'s [protocol_valid] is included in <<Y>>'s [valid].
- For all [protocol_valid] inputs (in <<X>>), <<Y>>'s [transition] acts
like <<X>>'s [transition].
*)

Section basic_VLSM_incl.

Context
  {message : Type}
  {T : VLSM_type message}
  {SX SY : VLSM_sign T}
  (MX : VLSM_class SX)
  (MY : VLSM_class SY)
  (X := mk_vlsm MX)
  (Y := mk_vlsm MY)
  .

Lemma VLSM_incl_finite_traces_characterization
  : VLSM_incl X Y <->
    forall (s : vstate X)
    (tr : list (vtransition_item X)),
    finite_protocol_trace X s tr -> finite_protocol_trace Y s tr.
Proof.
  split; intros Hincl.
  - intros. specialize (Hincl (Finite s tr)). apply Hincl. assumption.
  - intros tr Htr.
    destruct tr as [is tr | is tr]; simpl in *.
    + revert Htr. apply Hincl.
    + destruct Htr as [HtrX HisX].
      assert (His_tr: finite_protocol_trace X is []).
      { split; [|assumption]. constructor.
        apply initial_is_protocol. assumption.
      }
      apply Hincl in His_tr.
      destruct His_tr as [_ HisY].
      split; [|assumption].
      apply infinite_protocol_trace_from_prefix_rev.
      intros.
      apply infinite_protocol_trace_from_prefix with (n0 := n) in HtrX.
      apply (Hincl _ _ (conj HtrX HisX)).
Qed.

Context
  (Hinitial_state :
    forall s : state,
      vinitial_state_prop X s -> vinitial_state_prop Y s
  )
  (Hinitial_protocol_message :
    forall (l : label) (s : state) (m : message),
      vvalid X l (s, Some m) ->
      vinitial_message_prop X m ->
      protocol_message_prop Y m
  )
  (Hvalid :
    forall (l : label) (s : state) (om : option message),
      protocol_valid X l (s, om)
      -> vvalid Y l (s, om)
  )
  (Htransition :
    forall (l : label) (s : state) (om : option message),
      protocol_valid X l (s, om)
      -> vtransition X l (s, om) = vtransition Y l (s, om)
  )
  .

  Lemma protocol_props:
    forall som,
    protocol_prop X som ->
    protocol_state_prop Y (fst som)
    /\ ((exists l s, vvalid X l (s,snd som)) ->
      option_protocol_message_prop Y (snd som)).
  Proof.
    intros som H.
    induction H.
    - split.
      + apply initial_is_protocol.
        apply Hinitial_state.
        assumption.
      + intros [l [_s Hv]].
        destruct om;[|apply option_protocol_message_None].
        apply (Hinitial_protocol_message _ _ _ Hv).
        assumption.
    - rename IHprotocol_prop1 into IHs.
      rename IHprotocol_prop2 into IHm.
      simpl in IHm. destruct IHm as [_ IHm].
      simpl in IHs. destruct IHs as [IHs _].
      assert (protocol_valid X l1 (s,om)) as Hpvalid.
      {
        split. eexists;eassumption.
        split. eexists;eassumption.
        assumption.
      }
      specialize (IHm (ex_intro _ l1 (ex_intro _ s Hv))).
      clear Hv _om H _s H0.

      specialize (Htransition _ _ _ Hpvalid).
      change (transition l1) with (vtransition X l1).
      rewrite Htransition.
      assert (protocol_prop Y (vtransition Y l1 (s,om))).
      {
        destruct IHs as [_om Hs].
        destruct IHm as [_s Hm].
        apply (protocol_generated Y) with (_om:=_om) (_s:=_s).
        assumption.
        assumption.
        apply Hvalid;apply Hpvalid.
      }
      split;[|intros _];
        (eexists;rewrite <- surjective_pairing;exact H).
  Qed.

  Lemma Hprotocol_message :
    forall (l : label) (s : state) (om : option message),
      protocol_valid X l (s, om)
      -> option_protocol_message_prop Y om.
  Proof.
    intros l s [m|] H;[|apply option_protocol_message_None].
    destruct H as [_ [[_s H] Hv]].
    apply protocol_props in H.
    apply H.
    exists l, s.
    exact Hv.
  Qed.

  Lemma basic_VLSM_incl_protocol_state
        (s : state)
        (om : option message)
        (Hps : protocol_prop X (s,om))
    : protocol_state_prop Y s.
  Proof.
    apply protocol_props in Hps.
    apply Hps.
  Qed.

Lemma basic_VLSM_incl_protocol_transition
  (l : label)
  (is os : state)
  (iom oom : option message)
  (Ht : protocol_transition X l (is, iom) (os, oom))
  : protocol_transition Y l (is, iom) (os, oom).
Proof.
  destruct Ht as [[[_om Hps] [[_s Hpm] Hv]] Ht].
  specialize (protocol_generated_valid X Hps Hpm Hv); intros Hpv.
  repeat split.
  - apply basic_VLSM_incl_protocol_state with _om. assumption.
  - apply Hprotocol_message in Hpv. assumption.
  - specialize (Hvalid l is iom Hpv).
    assumption.
  - unfold vtransition in Htransition.
    rewrite <- Htransition; assumption.
Qed.

  Lemma basic_VLSM_incl_finite_protocol_trace
    (s : state)
    (ls : list transition_item)
    (Hpxt : finite_protocol_trace_from X s ls)
    : finite_protocol_trace_from Y s ls.
  Proof.
    induction Hpxt.
    - apply (finite_ptrace_empty Y).
      destruct H as [m H].
      apply basic_VLSM_incl_protocol_state in H. assumption.
    - apply (finite_ptrace_extend Y); try assumption.
      apply basic_VLSM_incl_protocol_transition. assumption.
  Qed.

  (* end hide *)

  Lemma basic_VLSM_incl
    : VLSM_incl X Y.
  Proof.
    apply VLSM_incl_finite_traces_characterization.
    intros s ls [Hxt Hinit].
    apply basic_VLSM_incl_finite_protocol_trace in Hxt.
    split; [assumption|].
    apply Hinitial_state. assumption.
  Qed.

End basic_VLSM_incl.

(** *** Pre-loaded VLSMs

Given a VLSM <<X>>, we introduce the _pre-loaded_ version of it,
which is identical to <<X>>, except that it is endowed with the
whole message universe as its initial messages. The high degree
of freedom allowed to the _pre-loaded_ version lets it experience
everything experienced by <<X>> but also other types of behaviour,
including _Byzantine_ behaviour, which makes it a useful concept in
Byzantine fault tolerance analysis.
*)

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

  Definition pre_loaded_with_all_messages_vlsm_sig
    : VLSM_sign (type X)
    :=
    {| initial_state_prop := vinitial_state_prop X
     ; initial_message_prop := fun message => True
     ; s0 := vs0 X
     ; m0 := vm0 X
     ; l0 := vl0 X
    |}.

  Definition pre_loaded_with_all_messages_vlsm_machine
    : VLSM_class pre_loaded_with_all_messages_vlsm_sig
    :=
    {| transition := vtransition X
     ; valid := vvalid X
    |}.

  Definition pre_loaded_with_all_messages_vlsm
    : VLSM message
    := mk_vlsm pre_loaded_with_all_messages_vlsm_machine.

  (**
    A message which can be emitted during a protocol run of
    the [pre_loaded_with_all_messages_vlsm] is called a [byzantine_message], because
    as shown by Lemmas [byzantine_pre_loaded_with_all_messages] and [pre_loaded_with_all_messages_alt_eq],
    byzantine traces for a [VLSM] are precisely the protocol traces
    of the [pre_loaded_with_all_messages_vlsm], hence a byzantine message is any message
    which a byzantine trace [can_emit].
  *)

  Definition byzantine_message_prop
    (m : message)
    : Prop
    := can_emit pre_loaded_with_all_messages_vlsm m.

  Definition byzantine_message : Type
    := sig byzantine_message_prop.

  (* begin hide *)
  Lemma pre_loaded_with_all_messages_message_protocol_prop
    (om : option message)
    : protocol_prop pre_loaded_with_all_messages_vlsm (proj1_sig (vs0 X), om).
  Proof.
    apply protocol_initial;[apply proj2_sig|].
    destruct om;exact I.
  Qed.

  Lemma pre_loaded_with_all_messages_protocol_prop
    (s : state)
    (om : option message)
    (Hps : protocol_prop X (s, om))
    : protocol_prop pre_loaded_with_all_messages_vlsm (s, om).
  Proof.
    induction Hps.
    - apply (protocol_initial pre_loaded_with_all_messages_vlsm).
      assumption.
      destruct om0;exact I.
    - apply (protocol_generated pre_loaded_with_all_messages_vlsm) with _om _s; assumption.
  Qed.

  Lemma pre_loaded_with_all_messages_protocol_state_prop
    (s : state)
    (Hps : protocol_state_prop X s)
    : protocol_state_prop pre_loaded_with_all_messages_vlsm s.
  Proof.
    unfold protocol_state_prop in *.
    destruct Hps as [om Hprs].
    exists om.
    apply pre_loaded_with_all_messages_protocol_prop.
    intuition.
  Qed.
  (* end hide *)

  Lemma any_message_is_protocol_in_preloaded (om: option message):
    option_protocol_message_prop pre_loaded_with_all_messages_vlsm om.
  Proof.
    eexists.
    apply pre_loaded_with_all_messages_message_protocol_prop.
  Qed.

  Inductive preloaded_protocol_state_prop : state -> Prop :=
  | preloaded_protocol_initial_state
      (s:state)
      (Hs: initial_state_prop (VLSM_sign:=pre_loaded_with_all_messages_vlsm_sig) s):
         preloaded_protocol_state_prop s
  | preloaded_protocol_generated
      (l : label)
      (s : state)
      (Hps : preloaded_protocol_state_prop s)
      (om : option message)
      (Hv : valid (VLSM_class:=pre_loaded_with_all_messages_vlsm_machine) l (s, om))
    : preloaded_protocol_state_prop
        (fst (transition (VLSM_class:=pre_loaded_with_all_messages_vlsm_machine) l (s, om))).

  Lemma preloaded_protocol_state_prop_iff s:
    protocol_state_prop pre_loaded_with_all_messages_vlsm s
    <-> preloaded_protocol_state_prop s.
  Proof.
    split.
    - intros [om Hproto].
      change s with (fst (s,om)).
      set (som:=(s,om)) in Hproto |- *.
      clearbody som;clear s om.
      induction Hproto.
      + apply preloaded_protocol_initial_state.
        assumption.
      + apply preloaded_protocol_generated;assumption.
    - induction 1.
      + exists None.
        apply protocol_initial;[assumption|exact I].
      + pose (som' := vtransition pre_loaded_with_all_messages_vlsm l1
                                  (s:vstate pre_loaded_with_all_messages_vlsm, om)).
        change (transition l1 (s,om)) with som'.
        exists (snd som').
        rewrite <- surjective_pairing.
        destruct IHpreloaded_protocol_state_prop as [_om IHs].
        pose proof (any_message_is_protocol_in_preloaded om) as [_s Hom].
        eapply protocol_generated;eassumption.
  Qed.

  Lemma preloaded_weaken_protocol_prop som:
    protocol_prop X som ->
    protocol_prop pre_loaded_with_all_messages_vlsm som.
  Proof.
    induction 1.
    - refine (protocol_initial pre_loaded_with_all_messages_vlsm s Hs om _).
      destruct om;exact I.
    - exact (protocol_generated pre_loaded_with_all_messages_vlsm l1
                                _ _ IHprotocol_prop1
                                _ _ IHprotocol_prop2 Hv).
  Qed.

  Lemma preloaded_weaken_protocol_transition
        l s om s' om':
    protocol_transition X l (s,om) (s',om') ->
    protocol_transition pre_loaded_with_all_messages_vlsm l (s,om) (s',om').
  Proof.
    unfold protocol_transition.
    intros [[[_om Hproto_s] [_ Hpvalid]] Htrans].
    split;[clear Htrans|assumption].
    split.
    - exists _om.
      apply preloaded_weaken_protocol_prop.
      assumption.
    - clear _om Hproto_s.
      split.
      + apply any_message_is_protocol_in_preloaded.
      + assumption.
  Qed.

  Lemma vlsm_incl_pre_loaded_with_all_messages_vlsm
    : VLSM_incl X pre_loaded_with_all_messages_vlsm.
  Proof.
    apply (basic_VLSM_incl (machine X) pre_loaded_with_all_messages_vlsm_machine)
    ; intros; try trivial.
    apply initial_message_is_protocol. exact I.
    apply H.
  Qed.

  Lemma pre_loaded_vlsm_incl
    (P Q : message -> Prop)
    (PimpliesQ : forall m : message, P m -> Q m)
    : VLSM_incl (pre_loaded_vlsm X P) (pre_loaded_vlsm X Q).
  Proof.
    destruct X as (T, (S, M)). intro Hpincl.
    apply basic_VLSM_incl; simpl; intros; [assumption| ..].
    - apply initial_message_is_protocol.
      destruct H0 as [Hinit|HP];[left|right];auto.
    - apply H.
    - reflexivity.
  Qed.

  Lemma pre_loaded_with_all_messages_vlsm_is_pre_loaded_with_True
    : VLSM_eq pre_loaded_with_all_messages_vlsm (pre_loaded_vlsm X (fun m => True)).
  Proof.
    unfold pre_loaded_with_all_messages_vlsm.
    unfold pre_loaded_vlsm.
    apply VLSM_eq_incl_iff.
    split.
    - apply
      (basic_VLSM_incl pre_loaded_with_all_messages_vlsm_machine (VLSM_class_pre_loaded_with_messages (projT2 (projT2 X))
        (fun _ : message => True))); intros; [assumption| | apply H |reflexivity].
      apply initial_message_is_protocol;right;exact I.
    - apply
      (basic_VLSM_incl (VLSM_class_pre_loaded_with_messages (projT2 (projT2 X))
                                                        (fun _ : message => True)) pre_loaded_with_all_messages_vlsm_machine ); intros; [assumption| | apply H |reflexivity].
      apply initial_message_is_protocol;exact I.
  Qed.

  Lemma pre_loaded_vlsm_incl_pre_loaded_with_all_messages
    (P : message -> Prop)
    : VLSM_incl (pre_loaded_vlsm X P) pre_loaded_with_all_messages_vlsm.
  Proof.
    apply VLSM_incl_trans with (machine (pre_loaded_vlsm X (fun _ => True))).
    - apply (pre_loaded_vlsm_incl P (fun _ => True)). intros. exact I.
    - apply VLSM_eq_incl_iff. apply pre_loaded_with_all_messages_vlsm_is_pre_loaded_with_True.
  Qed.

  Lemma vlsm_is_pre_loaded_with_False
    : VLSM_eq X (pre_loaded_vlsm X (fun m => False)).
  Proof.
    destruct X as (T, (S, M)). intro Hpp.
    apply VLSM_eq_incl_iff. simpl.
    split.
    - apply basic_VLSM_incl; intros; [assumption| | apply H |reflexivity].
      apply initial_message_is_protocol;left;assumption.
    - apply basic_VLSM_incl; intros; [assumption| | apply H |reflexivity].
      apply initial_message_is_protocol.
      destruct H0 as [|[]].
      assumption.
  Qed.

  Lemma vlsm_is_pre_loaded_with_False_protocol_prop
  (som : vstate X * option message)
  : protocol_prop X som <-> protocol_prop  (pre_loaded_vlsm X (fun m => False)) som.
  Proof.
    pose proof vlsm_is_pre_loaded_with_False as Heq.
    destruct X as (T, (S, M)).
    split;
      (apply protocol_prop_incl
      ;[|cbn;tauto]);
    intros t Ht;apply Heq;assumption.
  Qed.

End pre_loaded_with_all_messages_vlsm.

Lemma non_empty_protocol_trace_from_protocol_generated_prop
  `(X : VLSM message)
  (s : state)
  (m : message)
  : protocol_generated_prop X s m
  <-> exists (is : state) (tr : list transition_item) (item : transition_item),
    finite_protocol_trace X is tr /\
    last_error tr = Some item /\
    destination item = s /\ output item = Some m.
Proof.
  split.
  - intros [(s', om') [l Hsm]].
    destruct (id Hsm) as [[Hp _] _].
    pose proof (finite_ptrace_singleton _ Hsm) as Htr.
    apply finite_protocol_trace_from_complete_left in Htr.
    destruct  Htr as [is [trs [Htrs _]]].
    exists is.
    match type of Htrs with
    | context [_ ++ [?item]] => remember item as lstitem
    end.
    exists (trs ++ [lstitem]). exists lstitem.
    split; [assumption|].
    split; [apply last_error_is_last|].
    subst lstitem.
    split; reflexivity.
  - intros [is [tr [item [Htr [Hitem [Hs Hm]]]]]].
    destruct_list_last tr tr' item' Heq; [inversion Hitem|].
    clear Heq.
    rewrite last_error_is_last in Hitem. inversion Hitem. clear Hitem. subst item'.
    destruct Htr as [Htr _].
    apply finite_protocol_trace_from_app_iff in Htr.
    destruct Htr as [_ Htr].
    inversion Htr. clear Htr. subst. simpl in Hm. subst.
    eexists _, l1. apply H3.
Qed.

Lemma VLSM_incl_protocol_generated
  {message : Type}
  {vtype : VLSM_type message}
  {SigX SigY: VLSM_sign vtype}
  (MX : VLSM_class SigX) (MY : VLSM_class SigY)
  (X := mk_vlsm MX) (Y := mk_vlsm MY)
  (Hincl : VLSM_incl X Y)
  (s : state)
  (m : message)
  : protocol_generated_prop X s m -> protocol_generated_prop Y s m.
Proof.
  intro Hsm.
  apply non_empty_protocol_trace_from_protocol_generated_prop.
  apply non_empty_protocol_trace_from_protocol_generated_prop in Hsm.
  destruct Hsm as [is [tr [item [Htr Hsm]]]].
  exists is, tr, item.
  split; [|assumption]. clear Hsm.
  revert Htr.
  apply VLSM_incl_finite_protocol_trace.
  assumption.
Qed.

Lemma VLSM_incl_can_emit
  {message : Type}
  {vtype : VLSM_type message}
  {SigX SigY: VLSM_sign vtype}
  (MX : VLSM_class SigX) (MY : VLSM_class SigY)
  (X := mk_vlsm MX) (Y := mk_vlsm MY)
  (Hincl : VLSM_incl X Y)
  (m : message)
  : can_emit X m -> can_emit Y m.
Proof.
  repeat rewrite can_emit_iff.
  intros [s Hsm]. exists s. revert Hsm.
  apply VLSM_incl_protocol_generated. assumption.
Qed.

Lemma pre_loaded_with_all_messages_can_emit
  {message : Type}
  (X : VLSM message)
  (m : message)
  (Hm : can_emit X m)
  : can_emit (pre_loaded_with_all_messages_vlsm X) m.
Proof.
  apply (VLSM_incl_can_emit (machine X) (machine (pre_loaded_with_all_messages_vlsm X))).
  - apply (vlsm_incl_pre_loaded_with_all_messages_vlsm X).
  - rewrite mk_vlsm_machine;assumption.
Qed.