Require Import Coqlib.
Require Import ITreelib.
Require Import Skeleton.
Require Import PCM.
Require Import Any.
Require Import ModSem.
Require Import SimSTS.
Require Import STSNorm.
Require Import STS Behavior.

Set Implicit Arguments.

Section CONV.

  CoFixpoint decompile_STS
             (state: Type)
             (step: state -> option event -> state -> Prop)
             (state_sort: state -> sort):
    state -> itree eventE Any.t :=
    fun st0 =>
      match (state_sort st0) with
      | STS.angelic =>
        Vis (Take {st': state | @step st0 None st' })
            (fun st1 => decompile_STS step state_sort (proj1_sig st1))
      | STS.demonic =>
        Vis (Choose {st': state | @step st0 None st' })
            (fun st1 => decompile_STS step state_sort (proj1_sig st1))
      | STS.final z =>
        Ret (z)
      | STS.vis =>
        '(exist _ (event_sys fn args _) _) <-
        trigger (Choose {ev': event | exists st1, @step st0 (Some ev') st1 });;
        rv <- trigger (Syscall fn args (fun rv => exists st1, (@step st0 (Some (event_sys fn args rv)) st1)));;
        Vis (Choose {st1: state | @step st0 (Some (event_sys fn args rv)) st1 })
            (fun st1 => decompile_STS step state_sort (proj1_sig st1))
      end
  .

  Lemma unfold_decompile_STS
        (state: Type)
        (step: state -> option event -> state -> Prop)
        (state_sort: state -> sort)
        (st0: state):
    decompile_STS step state_sort st0
    =
    match (state_sort st0) with
    | STS.angelic =>
      Vis (Take {st': state | @step st0 None st' })
          (fun st1 => decompile_STS step state_sort (proj1_sig st1))
    | STS.demonic =>
      Vis (Choose {st': state | @step st0 None st' })
          (fun st1 => decompile_STS step state_sort (proj1_sig st1))
    | STS.final z =>
      Ret (z)
    | STS.vis =>
      '(exist _ (event_sys fn args _) _) <-
      trigger (Choose {ev': event | exists st1, @step st0 (Some ev') st1 });;
      rv <- trigger (Syscall fn args (fun rv => exists st1, (@step st0 (Some (event_sys fn args rv)) st1)));;
      Vis (Choose {st1: state | @step st0 (Some (event_sys fn args rv)) st1 })
          (fun st1 => decompile_STS step state_sort (proj1_sig st1))
    end
  .
  Proof.
    eapply observe_eta. reflexivity.
  Qed.

  (* Set Primitive Projections.  *)

End CONV.

Section PROOF.

  Import Behavior.Beh.

  Context {CONF: EMSConfig}.

  Variable
    (state: Type)
    (st_init0: state)
    (step0: state -> option event -> state -> Prop)
    (state_sort0: state -> sort).

  Hypothesis wf_vis0 :
    forall (st0 : state) (ev0 ev1 : option event) (st1 st2 : state),
      state_sort0 st0 = vis ->
      step0 st0 ev0 st1 -> step0 st0 ev1 st2 -> ev0 = ev1 -> st1 = st2.

  Hypothesis wf_vis_event0 :
    forall (st0 : state) (ev0 : option event) (st1 : state),
      state_sort0 st0 = vis ->
      step0 st0 ev0 st1 -> ev0 <> None.

  Hypothesis wf_angelic0 :
    forall (st0 : state) (ev : option event) (st1 : state),
      state_sort0 st0 = angelic -> step0 st0 ev st1 -> ev = None.

  Hypothesis wf_demonic0 :
    forall (st0 : state) (ev : option event) (st1 : state),
      state_sort0 st0 = demonic -> step0 st0 ev st1 -> ev = None.

  Hypothesis wf_final0 :
    forall st0 ev st1 r (FIN: state_sort0 st0 = final r) (STEP: step0 st0 ev st1),
      False.

  Let L0 :=
    {|
    STS.state := state;
    STS.step := step0;
    STS.initial_state := st_init0;
    STS.state_sort := state_sort0;
    STS.wf_vis := wf_vis0;
    STS.wf_vis_event := wf_vis_event0;
    STS.wf_angelic := wf_angelic0;
    STS.wf_demonic := wf_demonic0;
    STS.wf_final := wf_final0;
    |}
  .

  Let L1 := vis_normalize L0.

  Let step := norm_step state_sort0 step0.
  Let state_sort := norm_state_sort state_sort0.
  Let st_init := norm_state st_init0.

  Let wf_vis := L1.(wf_vis).
  Let wf_angelic := L1.(wf_angelic).
  Let wf_demonic := L1.(wf_demonic).

  Let STS_itree := decompile_STS step state_sort st_init.
  Let L1_itree := ModSemL.compile_itree STS_itree.

  Hypothesis wf_syscall0 :
    forall ev,
      (exists st0 st1, (state_sort0 st0 = vis) /\ (step0 st0 (Some ev) st1)) ->
      syscall_sem ev.

  Lemma wf_syscall :
    forall ev,
      (exists st0 st1, (state_sort st0 = vis) /\ (step st0 (Some ev) st1)) ->
      syscall_sem ev.
  Proof.
    i. des. unfold step in *. unfold state_sort in *.
    destruct st0. destruct st1. ss; clarify.
    destruct o; ss; clarify.
    2:{ destruct (state_sort0 s); ss; clarify. }
    inv H0. eapply wf_syscall0; eauto.
  Qed.

  Hypothesis wf_finalize0:
    forall st0 rv, state_sort0 st0 = final rv -> finalize (rv) = Some rv.

  Lemma wf_finalize:
    forall st0 rv, state_sort st0 = final rv -> finalize (rv) = Some rv.
  Proof.
    i. unfold state_sort, norm_state_sort in H. des_ifs. eapply wf_finalize0; et.
  Qed.

(**
of_state =
fun L1 : semantics => paco2 (_of_state L1) bot2
     : forall L1 : semantics, STS.state L1 -> Tr.t -> Prop

paco2 has 'fixed' semantics -> needs fixed semantics to do pcofix
 **)
  Lemma beh_preserved_L1_dir :
    forall st0 (tr: Tr.t),
      of_state
        L1_itree
        (decompile_STS step state_sort st0)
        tr
      ->
      of_state
        L1
        st0
        tr.
  Proof.
    Ltac mclo := eapply gpaco4_uclo; [eapply (@sim_mon L1 L1_itree)|eapply (@sim_indC_spec L1 L1_itree)|].
    Ltac mbase := gstep; [eapply (@sim_mon L1 L1_itree)|eapply sim_progress; [gbase; eauto|ss|ss]].
    intros st0. eapply adequacy_aux.
    instantiate (1:=false). instantiate (1:=false). ginit.
    revert st0. gcofix CIH. i. mclo.
    destruct (state_sort st0) eqn:SRT.
    - eapply sim_indC_angelic_src; ss; clarify. i. esplits; et.
      mclo. eapply sim_indC_angelic_tgt; ss; clarify.
      + rewrite unfold_decompile_STS. rewrite SRT. ss.
      + i.
        set (cont:= (fun st1 : {st' | step st0 None st'} => decompile_STS step state_sort (st1 $))).
        exists (cont (exist (fun st => step st0 None st) st_src1 STEP)). eexists.
        { rewrite unfold_decompile_STS. rewrite SRT. econs 3. }
        esplits; et. mbase.
    - eapply sim_indC_demonic_tgt; ss; clarify.
      + rewrite unfold_decompile_STS. rewrite SRT. ss.
      + i. rewrite unfold_decompile_STS in STEP. rewrite SRT in STEP.
        dependent destruction STEP.
        destruct x. rename x into st1.
        esplits; et. mclo. eapply sim_indC_demonic_src; ss; clarify.
        exists st1. eexists; auto.
        esplits; et. mbase.
    - eapply sim_indC_fin; eauto.
      ss. rewrite unfold_decompile_STS. rewrite SRT.
      unfold ModSemL.state_sort. ss.
      erewrite wf_finalize; et.
    - eapply sim_indC_demonic_tgt; ss; clarify.
      + rewrite unfold_decompile_STS. rewrite SRT. ss.
      + i. rewrite unfold_decompile_STS in STEP. rewrite SRT in STEP.
        rewrite bind_trigger in STEP.
        dependent destruction STEP.
        destruct x. des. destruct x.
        esplits; et.
        mclo. eapply sim_indC_vis; i; ss; clarify.
        rewrite bind_trigger in STEP.
        dependent destruction STEP.
        des. rename RETURN into STEP.
        exists st2. eexists.
        { auto. }
        esplits. mclo. eapply sim_indC_demonic_tgt; ss; clarify.
        i. dependent destruction STEP0.
        destruct x.
        esplits; et. mbase.
        assert (st2 = x).
        { eapply wf_vis. apply SRT. apply STEP. apply s. reflexivity. }
        clarify.
    Unshelve. all: try exact 0.
  Qed.

  Lemma beh_preserved_L1_inv :
    forall st0 (tr: Tr.t),
      of_state
        L1
        st0
        tr
      ->
      of_state
        L1_itree
        (decompile_STS step state_sort st0)
        tr.
  Proof.
    Ltac mclo2 := eapply gpaco4_uclo; [eapply (@sim_mon L1_itree L1)|eapply (@sim_indC_spec L1_itree L1)|].
    Ltac mbase2 := gstep; [eapply (@sim_mon L1_itree L1)|eapply sim_progress; [gbase; eauto|ss|ss]].
    intros st0. eapply adequacy_aux.
    instantiate (1:=false). instantiate (1:=false). ginit.
    revert st0.
    gcofix CIH. i. mclo2.
    destruct (state_sort st0) eqn:SRT.
    - eapply sim_indC_angelic_src; ss; clarify.
      + rewrite unfold_decompile_STS. rewrite SRT. ss.
      + i. rewrite unfold_decompile_STS in STEP. rewrite SRT in STEP.
        dependent destruction STEP. destruct x.
        esplits; et. mclo2. eapply sim_indC_angelic_tgt; ss; clarify.
        exists x. exists s. esplits; et. mbase2.
    - eapply sim_indC_demonic_tgt; ss; clarify. i.
      esplits; et. mclo2. eapply sim_indC_demonic_src; ss; clarify.
      + rewrite unfold_decompile_STS. rewrite SRT. ss.
      + i. exists (decompile_STS step state_sort st_tgt1).
        eexists.
        { rewrite unfold_decompile_STS in *. rewrite SRT in *.
          apply (ModSemL.step_choose (fun st1 : {st' | step st0 None st'} => decompile_STS step state_sort (st1 $)) (exist _ st_tgt1 STEP)). }
        esplits; et. mbase2.
    - econs; ss.
      + rewrite unfold_decompile_STS. rewrite SRT.
        unfold ModSemL.state_sort. ss.
        erewrite wf_finalize; et.
      + auto.
    - assert (CASE: (forall ev st1, not (step st0 (Some ev) st1)) \/ (exists ev st1, (step st0 (Some ev) st1))).
      { destruct (classic (exists ev st1, step st0 (Some ev) st1)); eauto.
        left. ii. apply H. eauto. }
      destruct CASE.
      + eapply sim_indC_vis_stuck_tgt; eauto.
      + set (cont := fun x_ : {ev' : event | exists st1, step st0 (Some ev') st1} =>
                       (let (x, _) := x_ in
                        match x with
                        | event_sys fn args _ =>
                          ` rv0 : Any.t <-
                                  trigger
                                    (Syscall fn args
                                             (fun rv0 : Any.t =>
                                                exists st1, step st0 (Some (event_sys fn args rv0)) st1));;
                                  Vis
                                    (Choose {st1 | step st0 (Some (event_sys fn args rv0)) st1})
                                    (fun
                                        st1 : {st1 | step st0 (Some (event_sys fn args rv0)) st1}
                                      => decompile_STS step state_sort (st1 $))
                        end)).
        destruct H.
        eapply sim_indC_demonic_src; ss; clarify.
        { rewrite unfold_decompile_STS. rewrite SRT. ss. }
        exists (cont (exist (fun 'ev => exists st1, step st0 (Some ev) st1) x H)).
        destruct x. eexists.
        { rewrite unfold_decompile_STS. rewrite SRT. ss. rewrite bind_trigger.
          eapply (ModSemL.step_choose cont (exist (fun 'ev => exists st1, step st0 (Some ev) st1) (event_sys fn args rv) H)). }
        esplits; et.
        mclo2. destruct H. rename s into STEP. subst cont.
        set (cont := fun rv0 =>
                       Vis
                         (Choose
                            {st1 | step st0 (Some (event_sys fn args rv0)) st1})
                         (fun
                             st1 : {st1 | step st0 (Some (event_sys fn args rv0)) st1} =>
                             decompile_STS step state_sort (st1 $))).
        eapply sim_indC_vis; eauto.
        i. ss.
        exploit wf_vis_norm.
        { instantiate (1:= L1). exists L0. reflexivity. }
        { ss. apply SRT. }
        { apply STEP. }
        { apply STEP0. }
        i. des. clarify.
        exists (cont rv). eexists.
        { ss. rewrite bind_trigger. subst cont. ss.
          apply (@ModSemL.step_syscall fn args rv (fun rv0 : Any.t => exists st1, step st0 (Some (event_sys fn args rv0)) st1) (fun x : Any.t => Vis (Choose {st1 | step st0 (Some (event_sys fn args x)) st1}) (fun st1 : {st1 | step st0 (Some (event_sys fn args x)) st1} => decompile_STS step state_sort (st1 $)))).
          2:{ exists st_tgt1. auto. }
          apply wf_syscall.
          exists st0, st_tgt1. auto. }
        esplits. mclo2. eapply sim_indC_demonic_src; ss; clarify.
        subst cont. ss.
        set (cont :=
               (fun
                   st1 :
                     {st1 | step st0
                                 (Some (event_sys fn args rv))
                                 st1} =>
                   decompile_STS step state_sort (st1 $))).
        exists (cont (exist (fun st1 => step st0 (Some (event_sys fn args rv)) st1) st_tgt1 STEP)).
        eexists.
        { econs. }
        esplits; et. mbase2.
    Unshelve. all: try exact 0.
  Qed.

  Lemma beh_preserved_L1 :
    forall st0 (tr: Tr.t),
      of_state L1 st0 tr
      <->
      of_state
        L1_itree
        (decompile_STS step state_sort st0)
        tr.
  Proof.
    split.
    - apply beh_preserved_L1_inv.
    - apply beh_preserved_L1_dir.
  Qed.

  Theorem beh_preserved :
    exists itr, forall tr,
        of_state L0 st_init0 tr
        <->
        of_state (ModSemL.compile_itree itr) itr tr.
  Proof.
    exists STS_itree. i.
    assert (A: of_state (ModSemL.compile_itree STS_itree) STS_itree tr
               =
               of_state L1_itree (decompile_STS step state_sort st_init) tr).
    { ss. }
    rewrite A.
    rewrite <- (beh_preserved_L1 st_init tr).
    rewrite STSNorm.beh_preserved. eauto.
  Qed.

End PROOF.

(* Import Behavior.Beh. *)

(* Theorem exists_itree : *)
(*   forall (L1: semantics), *)
(*     (forall ev, *)
(*         (exists st0 st1, (state_sort L1 st0 = vis) /\ (step L1 st0 (Some ev) st1)) -> *)
(*         syscall_sem ev) -> *)
(*     exists itr, forall tr, *)
(*         of_state L1 L1.(initial_state) tr *)
(*         <-> *)
(*         of_state (interpITree itr) itr tr. *)
(* Proof. *)
(*   i. destruct L1. ss. *)
(*   revert state initial_state step state_sort wf_vis wf_angelic wf_demonic H. *)
(*   eapply PROOF.beh_preserved. *)

(* (** Universe consistency *) *)


(*
 * © 2019 XXX.
 *
 * SPDX-License-Identifier: MIT
 *
 *)
From Coq Require Import
     String
     Sumbool
     Morphisms.

From SPICY Require Import
     MyPrelude
     Maps
     Keys
     Messages.

Set Implicit Arguments.

Module RW_message <: GRANT_ACCESS.
  Definition access := key_permission.
End RW_message.

Module message := Messages(RW_message).
Import message.
Export message.

Definition cipher_id := nat.

Inductive crypto : type -> Type :=
| Content {t} (c : message t) : crypto t
| SignedCiphertext {t} (c_id : cipher_id) : crypto t
.

(* We need to handle non-deterministic message  -- external choice on ordering *)
Inductive msg_pat :=
| Accept
| Signed (k : key_identifier) (chk_replay : bool)
| SignedEncrypted (k__sign k__enc : key_identifier) (chk_replay : bool)
.

Definition msg_seq : Set := (option user_id) * nat.

Definition msg_seq_eq (s1 s2 : msg_seq) : {s1 = s2} + {s1 <> s2}.
  repeat (decide equality).
Defined.

Inductive cipher : Type :=
| SigCipher {t} (k__sign : key_identifier) (msg_to : user_id) (c_nonce : msg_seq) (msg : message t) : cipher
| SigEncCipher {t} (k__sign k__enc : key_identifier) (msg_to : user_id) (c_nonce : msg_seq) (msg : message t) : cipher
.

Definition cipher_signing_key (c : cipher) :=
  match c with
  | SigCipher k _ _ _      => k
  | SigEncCipher k _ _ _ _ => k
  end.

Definition cipher_to_user (c : cipher) :=
  match c with
  | SigCipher _ to _ _      => to
  | SigEncCipher _ _ to _ _ => to
  end.

Definition cipher_nonce (c : cipher) :=
  match c with
  | SigCipher _ _ n _      => n
  | SigEncCipher _ _ _ n _ => n
  end.

Definition queued_messages := list (sigT crypto).
Definition ciphers         := NatMap.t cipher.
Definition my_ciphers      := list cipher_id.
Definition recv_nonces     := list msg_seq.
Definition sent_nonces     := list msg_seq.

Inductive msg_accepted_by_pattern (cs : ciphers) (opt_uid_to : option user_id) (froms : recv_nonces)
  : forall {t : type}, msg_pat -> crypto t -> Prop :=
| MsgAccept : forall {t} (m : crypto t),
    msg_accepted_by_pattern cs opt_uid_to froms Accept m
| ProperlySigned : forall {t t'} c_id k (m : message t) msg_to nonce (chk : bool),
    cs $? c_id = Some (SigCipher k msg_to nonce m)
    -> (if chk then (count_occ msg_seq_eq froms nonce = 0) else True)
    -> opt_uid_to = Some msg_to
    -> msg_accepted_by_pattern cs opt_uid_to froms (Signed k chk) (@SignedCiphertext t' c_id)
| ProperlyEncrypted : forall {t t'} c_id k__sign k__enc (m : message t) msg_to nonce (chk : bool),
    cs $? c_id = Some (SigEncCipher k__sign k__enc msg_to nonce m)
    -> (if chk then (count_occ msg_seq_eq froms nonce = 0) else True)
    -> opt_uid_to = Some msg_to
    -> msg_accepted_by_pattern cs opt_uid_to froms (SignedEncrypted k__sign k__enc chk) (@SignedCiphertext t' c_id).

#[export] Hint Extern 1 (~ In _ _) => rewrite not_find_in_iff : core.

Notation honest_key honk kid := (honk $? kid = Some true).

Section SafeMessages.
  Variable all_keys : keys.
  Variable honestk advk : key_perms.

  Definition honest_keyb (k_id : key_identifier) : bool :=
    match honestk $? k_id with
    | Some true => true
    | _ => false
    end.

  Definition msg_cipher_id {t} (msg : crypto t) : option cipher_id :=
    match msg with
    | SignedCiphertext c_id => Some c_id
    | _ => None
    end.

  Definition msg_signing_key {t} (cs : ciphers) (msg : crypto t) : option key_identifier :=
    match msg with
    | Content _ => None
    | SignedCiphertext c_id =>
      match cs $? c_id with
      | Some c => Some (cipher_signing_key c)
      | None   => None
      end
    end.

  Definition msg_destination_user {t} (cs : ciphers) (msg : crypto t) : option user_id :=
    match msg with
    | Content _ => None
    | SignedCiphertext c_id =>
      match cs $? c_id with
      | Some c => Some (cipher_to_user c)
      | None   => None
      end
    end.

  Definition msg_honestly_signed {t} (cs : ciphers) (msg : crypto t) : bool :=
    match msg_signing_key cs msg with
    | Some k => honest_keyb k
    | _ => false
    end.

  Definition msg_to_this_user {t} (cs : ciphers) (to_usr : option user_id) (msg : crypto t) : bool :=
    match msg_destination_user cs msg with
    | Some to_usr' => match to_usr with
                     | None => true
                     | Some to_hon_user => if to_usr' ==n to_hon_user then true else false
                     end
    | _ => false
    end.

  Definition msg_signed_addressed (cs : ciphers) (to_user_id : option user_id) {t} (msg : crypto t) :=
    msg_honestly_signed cs msg && msg_to_this_user cs to_user_id msg.

  Definition keys_mine (my_perms key_perms: key_perms) : Prop :=
    forall k_id kp,
      key_perms $? k_id = Some kp
    ->  my_perms $? k_id = Some kp
    \/ (my_perms $? k_id = Some true /\ kp = false).

  Definition cipher_honestly_signed (c : cipher) : bool :=
    match c with
    | SigCipher k_id _ _ _              => honest_keyb k_id
    | SigEncCipher k__signid k__encid _ _ _ => honest_keyb k__signid
    end.

  Definition ciphers_honestly_signed :=
    Forall_natmap (fun c => cipher_honestly_signed c = true).

  Inductive msg_pattern_safe : msg_pat -> Prop :=
  | HonestlySignedSafe : forall k,
        honest_key honestk k
      -> msg_pattern_safe (Signed k true)
  | HonestlySignedEncryptedSafe : forall k__sign k__enc,
        honest_key honestk k__sign
      -> msg_pattern_safe (SignedEncrypted k__sign k__enc true)
  .

End SafeMessages.

Inductive user_cmd_type :=
| Base (t : type)
| Message (t : type)
| Crypto (t : type)
| UPair (t1 t2 : user_cmd_type)
.

Fixpoint denote (t : user_cmd_type) :=
  match t with
  | Base t' => message.typeDenote t'
  | Message t' => message t'
  | Crypto t' => crypto t'
  | UPair t1 t2 => (denote t1 * denote t2)%type
  end
.

Declare Scope realworld_scope.
Notation "<< t >>" := (denote t) (at level 75) : realworld_scope.
Delimit Scope realworld_scope with realworld.
Open Scope realworld_scope.

Inductive user_cmd : user_cmd_type -> Type :=
(* Plumbing *)
| Return {A} (res : <<A>>%realworld) : user_cmd A
| Bind {A A'} (cmd1 : user_cmd A') (cmd2 : <<A'>>%realworld -> user_cmd A) : user_cmd A

| Gen : user_cmd (Base Nat)

(* Messaging *)
| Send {t} (uid : user_id) (msg : crypto t) : user_cmd (Base Unit)
| Recv {t} (pat : msg_pat) : user_cmd (Crypto t)

(* Crypto!! *)
| SignEncrypt {t} (k__sign k__enc : key_identifier) (msg_to : user_id) (msg : message t) : user_cmd (Crypto t)
| Decrypt {t} (c : crypto t) : user_cmd (Message t)

| Sign    {t} (k : key_identifier) (msg_to : user_id) (msg : message t) : user_cmd (Crypto t)
| Verify  {t} (k : key_identifier) (c : crypto t) : user_cmd (UPair (Base Bool) (Message t))

| GenerateKey (kt : key_type) (usage : key_usage) : user_cmd (Base Access)
.

Module RealWorldNotations.
  Ltac denoteInvert T :=
    match T with
      | key_permission => exact (Base Access)
      | bool => exact (Base Bool)
      | nat => exact (Base Nat)
      | unit => exact (Base Unit)
      | (?T1 * ?T2)%type =>
        exact (UPair ltac:(denoteInvert T1) ltac:(denoteInvert T2))
      end
  .
  Ltac typeOf x :=
    match type of x with
    | ?T => denoteInvert T
    end
  .
  Notation "x <- c1 ; c2" := (Bind c1 (fun x => c2)) (right associativity, at level 75) : realworld_scope.
  Notation "'ret' x" := (@Return ltac:(typeOf x) x) (at level 75, only parsing) : realworld_scope.
End RealWorldNotations.
Import  RealWorldNotations.

Record user_data (A : type) :=
  mkUserData {
      key_heap  : key_perms
    ; protocol  : user_cmd (Base A)
    ; msg_heap  : queued_messages
    ; c_heap    : my_ciphers
    ; from_nons : recv_nonces
    ; sent_nons : sent_nonces
    ; cur_nonce : nat
    }.

Definition honest_users A := NatMap.t (user_data A).

Record simpl_universe A :=
  mkSimplUniverse {
      s_users       : honest_users A
    ; s_all_ciphers : ciphers
    ; s_all_keys    : keys
    }.

Record universe A B :=
  mkUniverse {
      users       : honest_users A
    ; adversary   : user_data B
    ; all_ciphers : ciphers
    ; all_keys    : keys
    }.

Definition peel_adv {A B} (U : universe A B) : simpl_universe A :=
   {| s_users       := U.(users)
    ; s_all_ciphers := U.(all_ciphers)
    ; s_all_keys    := U.(all_keys) |}.

Definition findUserKeys {A} (us : NatMap.t (user_data A)) : key_perms :=
  fold (fun u_id u ks => ks $k++ u.(key_heap)) us $0.

Definition addUserKeys {A} (ks : key_perms) (u : user_data A) : user_data A :=
  {| key_heap  := u.(key_heap) $k++ ks
   ; protocol  := u.(protocol)
   ; msg_heap  := u.(msg_heap)
   ; c_heap    := u.(c_heap)
   ; from_nons := u.(from_nons)
   ; sent_nons := u.(sent_nons)
   ; cur_nonce := u.(cur_nonce)
  |}.

Definition addUsersKeys {A} (us : NatMap.t (user_data A)) (ks : key_perms) :=
  map (addUserKeys ks) us.

Fixpoint findKeysMessage {t} (msg : message t) : key_perms :=
  match msg with
  | message.Permission k => $0 $+ (fst k, snd k)
  | message.Content _ => $0
  | message.MsgPair m1 m2 => findKeysMessage m1 $k++ findKeysMessage m2
  end.

Definition findKeysCrypto {t} (cs : ciphers) (msg : crypto t) : key_perms :=
  match msg with
  | Content  m          => findKeysMessage m
  | SignedCiphertext c_id  =>
    match cs $? c_id with
    | Some (SigCipher _ _ _ m) => findKeysMessage m
    | _ => $0
    end
  end.

Definition findCiphers {t} (msg : crypto t) : my_ciphers :=
  match msg with
  | Content _          => []
  | SignedCiphertext c => [c]
  end.

Definition findMsgCiphers {t} (msg : crypto t) : queued_messages :=
  match msg with
  | Content _          => []
  | SignedCiphertext _ => [existT _ _ msg]
  end.

Definition user_keys {A} (usrs : honest_users A) (u_id : user_id) : option key_perms :=
  match usrs $? u_id with
  | Some u_d => Some u_d.(key_heap)
  | None     => None
  end.

Definition user_queue {A} (usrs : honest_users A) (u_id : user_id) : option queued_messages :=
  match usrs $? u_id with
  | Some u_d => Some u_d.(msg_heap)
  | None     => None
  end.

Definition user_cipher_queue {A} (usrs : honest_users A) (u_id : user_id) : option my_ciphers :=
  match usrs $? u_id with
  | Some u_d => Some u_d.(c_heap)
  | None     => None
  end.

Definition buildUniverse {A B}
           (usrs : honest_users A) (adv : user_data B) (cs : ciphers) (ks : keys)
           (u_id : user_id) (userData : user_data A) : universe A B :=
  {| users        := usrs $+ (u_id, userData)
   ; adversary    := adv
   ; all_ciphers  := cs
   ; all_keys     := ks
   |}.

Definition buildUniverseAdv {A B}
           (usrs : honest_users A) (cs : ciphers) (ks : keys)
           (userData : user_data B) : universe A B :=
  {| users        := usrs
   ; adversary    := userData
   ; all_ciphers  := cs
   ; all_keys     := ks
   |}.

Definition updateTrackedNonce {t} (to_usr : option user_id) (froms : recv_nonces) (cs : ciphers) (msg : crypto t) :=
  match msg with
  | Content _ => froms
  | SignedCiphertext c_id =>
    match cs $? c_id with
    | None => froms
    | Some c =>
      match to_usr with
      | None => froms
      | Some to_uid =>
        if to_uid ==n cipher_to_user c
        then match count_occ msg_seq_eq froms (cipher_nonce c) with
             | 0 => cipher_nonce c :: froms
             | _ => froms
             end
        else froms
      end
    end
  end.

Definition updateSentNonce {t} (to_usr : option user_id) (sents : sent_nonces) (cs : ciphers) (msg : crypto t) :=
  match msg with
  | Content _ => sents
  | SignedCiphertext c_id =>
    match cs $? c_id with
    | None => sents
    | Some c =>
      match to_usr with
      | None => sents
      | Some to_uid =>
        if to_uid ==n cipher_to_user c
        then cipher_nonce c :: sents
        else sents
      end
    end
  end.

Definition msg_nonce_not_same (new_cipher : cipher) (cs : ciphers) {t} (msg : crypto t) : Prop :=
  forall c_id c,
    msg = SignedCiphertext c_id
    -> cs $? c_id = Some c
    -> cipher_nonce new_cipher <> cipher_nonce c.

Definition msg_nonce_same (new_cipher : cipher) (cs : ciphers) {t} (msg : crypto t) : Prop :=
  forall c_id c,
      msg = SignedCiphertext c_id
    -> cs $? c_id = Some c
    -> cipher_nonce new_cipher = cipher_nonce c.

Definition msg_not_replayed {t} (to_usr : option user_id) (cs : ciphers) (froms : recv_nonces) (msg : crypto t) (msgs : queued_messages) : Prop :=
  exists c_id c,
      msg = SignedCiphertext c_id
    /\ cs $? c_id = Some c
    /\ ~ List.In (cipher_nonce c) froms
    /\ Forall (fun sigM => match sigM with
                       | (existT _ _ m) => msg_to_this_user cs to_usr m = true
                                        -> msg_nonce_not_same c cs m
                       end) msgs.

Inductive action : Type :=
| Input  t (msg : crypto t) (pat : msg_pat) (froms : recv_nonces)
| Output t (msg : crypto t) (from_user : option user_id) (to_user : option user_id) (sents : sent_nonces)
.

Definition rlabel := @label action.
Definition uaction := (user_id * action)%type.
Definition ulabel := @label uaction.
Definition mkULbl (lbl : rlabel) (uid : user_id) : ulabel :=
  match lbl with
  | Silent => Silent
  | Action a => Action (uid, a)
  end.

Definition data_step0 A B C : Type :=
  honest_users A * user_data B * ciphers * keys * key_perms * queued_messages * my_ciphers * recv_nonces * sent_nonces * nat * user_cmd C.

Definition build_data_step {A B C} (U : universe A B) (u_data : user_data C) : data_step0 A B (Base C) :=
  (U.(users), U.(adversary), U.(all_ciphers), U.(all_keys),
   u_data.(key_heap), u_data.(msg_heap), u_data.(c_heap), u_data.(from_nons), u_data.(sent_nons), u_data.(cur_nonce), u_data.(protocol)).

Inductive step_user : forall A B C, rlabel -> option user_id -> data_step0 A B C -> data_step0 A B C -> Prop :=

(* Plumbing *)
| StepBindRecur : forall {A B r r'} (usrs usrs' : honest_users A) (adv adv' : user_data B)
                    lbl u_id cs cs' qmsgs qmsgs' gks gks' ks ks' mycs mycs' froms froms' sents sents' cur_n cur_n'
                    (cmd1 cmd1' : user_cmd r) (cmd2 : <<r>> -> user_cmd r'),
    step_user lbl u_id (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, cmd1)
                       (usrs', adv', cs', gks', ks', qmsgs', mycs', froms', sents', cur_n', cmd1')
    -> step_user lbl u_id (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, Bind cmd1 cmd2)
                         (usrs', adv', cs', gks', ks', qmsgs', mycs', froms', sents', cur_n', Bind cmd1' cmd2)
| StepBindProceed : forall {A B r r'} (usrs : honest_users A) (adv : user_data B) cs u_id gks ks qmsgs mycs froms sents cur_n
                      (v : <<r'>>) (cmd : <<r'>> -> user_cmd r),
    step_user Silent u_id
              (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, Bind (@Return r' v) cmd)
              (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, cmd v)

| StepGen : forall {A B} (usrs : honest_users A) (adv : user_data B) cs u_id gks ks qmsgs mycs froms sents cur_n n,
    step_user Silent u_id (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, Gen)
              (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, Return n)

(* Comms  *)
| StepRecv : forall {A B} {t} (usrs : honest_users A) (adv : user_data B) cs u_id gks ks ks' qmsgs qmsgs' mycs mycs' froms froms'
               sents cur_n (msg : crypto t) msgs__front msgs__back pat newkeys newcs,
      qmsgs = msgs__front ++ (existT _ _ msg) :: msgs__back (* we have a message waiting for us! *)
    -> qmsgs' = msgs__front ++ msgs__back
    -> findKeysCrypto cs msg = newkeys
    -> newcs = findCiphers msg
    -> ks' = ks $k++ newkeys
    -> mycs' = newcs ++ mycs
    -> froms' = updateTrackedNonce u_id froms cs msg
    -> msg_accepted_by_pattern cs u_id froms pat msg
    -> Forall (fun '(existT _ _ msg')  => ~ msg_accepted_by_pattern cs u_id froms pat msg') msgs__front
    -> step_user (Action (Input msg pat froms)) u_id
                (usrs, adv, cs, gks, ks , qmsgs , mycs, froms, sents, cur_n,  Recv pat)
                (usrs, adv, cs, gks, ks', qmsgs', mycs', froms', sents, cur_n, @Return (Crypto t) msg)

(* Augment attacker's keys with those available through messages sent, *)
(*  * including traversing through ciphers already known by attacker, etc. *)
(*  *)
| StepSend : forall {A B} {t} (usrs usrs' : honest_users A) (adv adv' : user_data B)
               cs suid gks ks qmsgs mycs froms sents sents' cur_n rec_u_id rec_u newkeys (msg : crypto t),
    findKeysCrypto cs msg = newkeys
    -> keys_mine ks newkeys
    -> incl (findCiphers msg) mycs
    -> usrs $? rec_u_id = Some rec_u
    -> Some rec_u_id <> suid
    -> sents' = updateSentNonce (Some rec_u_id) sents cs msg
    -> usrs' = usrs $+ (rec_u_id, {| key_heap  := rec_u.(key_heap)
                                  ; protocol  := rec_u.(protocol)
                                  ; msg_heap  := rec_u.(msg_heap) ++ [existT _ _ msg]
                                  ; c_heap    := rec_u.(c_heap)
                                  ; from_nons := rec_u.(from_nons)
                                  ; sent_nons := rec_u.(sent_nons)
                                  ; cur_nonce := rec_u.(cur_nonce) |})
    -> adv' =
      {| key_heap  := adv.(key_heap) $k++ newkeys
       ; protocol  := adv.(protocol)
       ; msg_heap  := adv.(msg_heap) ++ [existT _ _ msg]
       ; c_heap    := adv.(c_heap)
       ; from_nons := adv.(from_nons)
       ; sent_nons := adv.(sent_nons)
       ; cur_nonce := adv.(cur_nonce) |}
    -> step_user (Action (Output msg suid (Some rec_u_id) sents)) suid
                (usrs , adv , cs, gks, ks, qmsgs, mycs, froms, sents,  cur_n, Send rec_u_id msg)
                (usrs', adv', cs, gks, ks, qmsgs, mycs, froms, sents', cur_n, @Return (Base Unit) tt)

(* Encryption / Decryption *)
| StepEncrypt : forall {A B} {t} (usrs : honest_users A) (adv : user_data B) cs cs' u_id gks ks qmsgs mycs mycs' froms sents
                  cur_n cur_n' (msg : message t) k__signid k__encid kp__enc kt__enc kt__sign c_id cipherMsg msg_to msg_nonce,
      gks $? k__encid  = Some (MkCryptoKey k__encid Encryption kt__enc)
    -> gks $? k__signid = Some (MkCryptoKey k__signid Signing kt__sign)
    -> ks $? k__encid   = Some kp__enc
    -> ks $? k__signid  = Some true
    -> ~ In c_id cs
    -> keys_mine ks (findKeysMessage msg)
    -> cur_n' = 1 + cur_n
    -> (u_id <> None -> msg_nonce = (u_id, cur_n))
    -> cipherMsg = SigEncCipher k__signid k__encid msg_to msg_nonce msg
    -> cs' = cs $+ (c_id, cipherMsg)
    -> mycs' = c_id :: mycs
    -> step_user Silent u_id
                (usrs, adv, cs , gks, ks, qmsgs, mycs,  froms, sents, cur_n,  SignEncrypt k__signid k__encid msg_to msg)
                (usrs, adv, cs', gks, ks, qmsgs, mycs', froms, sents, cur_n', @Return (Crypto t) (SignedCiphertext c_id))

| StepDecrypt : forall {A B} {t} (usrs : honest_users A) (adv : user_data B) cs u_id gks ks ks' qmsgs mycs mycs'
                  (msg : message t) k__signid kp__sign k__encid c_id nonce newkeys kt__sign kt__enc msg_to froms sents cur_n,
      cs $? c_id     = Some (SigEncCipher k__signid k__encid msg_to nonce msg)
    -> gks $? k__encid  = Some (MkCryptoKey k__encid Encryption kt__enc)
    -> gks $? k__signid = Some (MkCryptoKey k__signid Signing kt__sign)
    -> ks  $? k__encid  = Some true
    -> ks  $? k__signid = Some kp__sign
    -> findKeysMessage msg = newkeys
    -> ks' = ks $k++ newkeys
    -> mycs' = (* newcs ++  *)mycs
    -> List.In c_id mycs
    -> step_user Silent u_id
                (usrs, adv, cs, gks, ks , qmsgs, mycs,  froms, sents, cur_n, Decrypt (SignedCiphertext c_id))
                (usrs, adv, cs, gks, ks', qmsgs, mycs', froms, sents, cur_n, @Return (Message t) msg)

(* Signing / Verification *)
| StepSign : forall {A B} {t} (usrs : honest_users A) (adv : user_data B) cs cs' u_id gks ks qmsgs mycs mycs'
               froms sents cur_n cur_n' msg_nonce (msg : message t) k_id kt c_id cipherMsg msg_to,
      gks $? k_id = Some (MkCryptoKey k_id Signing kt)
    -> ks  $? k_id = Some true
    -> ~ In c_id cs
    -> keys_mine ks (findKeysMessage msg)
    -> cur_n' = 1 + cur_n
    -> (u_id <> None -> msg_nonce = (u_id, cur_n))
    -> cipherMsg = SigCipher k_id msg_to msg_nonce msg
    -> cs' = cs $+ (c_id, cipherMsg)
    -> mycs' = c_id :: mycs
    -> step_user Silent u_id
                (usrs, adv, cs , gks, ks, qmsgs, mycs,  froms, sents, cur_n,  Sign k_id msg_to msg)
                (usrs, adv, cs', gks, ks, qmsgs, mycs', froms, sents, cur_n', @Return (Crypto t) (SignedCiphertext c_id))

| StepVerify : forall {A B} {t} (usrs : honest_users A) (adv : user_data B) cs u_id gks ks qmsgs mycs froms sents cur_n
                 (msg : message t) k_id kp kt c_id nonce msg_to,
      gks $? k_id = Some (MkCryptoKey k_id Signing kt)
    -> ks  $? k_id = Some kp
    -> cs $? c_id = Some (SigCipher k_id msg_to nonce msg)
    -> List.In c_id mycs
    -> step_user Silent u_id
                (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, Verify k_id (SignedCiphertext c_id))
                (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, @Return (UPair (Base Bool) (Message t))(true, msg))

| StepGenerateKey: forall {A B} (usrs : honest_users A) (adv : user_data B)
                     cs u_id gks gks' ks ks' qmsgs mycs froms sents cur_n
                     (k_id : key_identifier) k kt usage,
    gks $? k_id = None
    -> k = MkCryptoKey k_id usage kt
    -> gks' = gks $+ (k_id, k)
    -> ks' = add_key_perm k_id true ks
    -> step_user Silent u_id
                (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, GenerateKey kt usage)
                (usrs, adv, cs, gks', ks', qmsgs, mycs, froms, sents, cur_n, @Return (Base Access) (k_id, true))

.

Inductive step_universe {A B} : option user_id -> universe A B -> ulabel -> universe A B -> Prop :=
| StepUser : forall U U' (u_id : user_id) userData usrs adv cs gks ks qmsgs mycs froms sents cur_n lbl lbl' (cmd : user_cmd (Base A)),
    U.(users) $? u_id = Some userData
    -> step_user lbl (Some u_id)
                (build_data_step U userData)
                (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, cmd)
    -> U' = buildUniverse usrs adv cs gks u_id {| key_heap  := ks
                                               ; msg_heap  := qmsgs
                                               ; protocol  := cmd
                                               ; c_heap    := mycs
                                               ; from_nons := froms
                                               ; sent_nons := sents
                                               ; cur_nonce := cur_n |}
    -> lbl' = mkULbl lbl u_id
    -> step_universe (Some u_id) U lbl' U'
| StepAdversary : forall U U' usrs adv cs gks ks qmsgs mycs froms sents cur_n lbl (cmd : user_cmd (Base B)),
    step_user lbl None
              (build_data_step U U.(adversary))
              (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, cmd)
    -> U' = buildUniverseAdv usrs cs gks {| key_heap  := ks
                                         ; msg_heap  := qmsgs
                                         ; protocol  := cmd
                                         ; c_heap    := mycs
                                         ; from_nons := froms
                                         ; sent_nons := sents
                                         ; cur_nonce := cur_n |}
    -> step_universe None U Silent U'
.


Require Coq.Structures.Equalities.
Require Coq.FSets.FSetAVL.
Require Coq.FSets.FSetWeakList.
Require Coq.FSets.FMapFacts.
Require Coq.Lists.List.

Require Genevan.ProtoIdentifier.
Require Genevan.ProtoName.
Require Genevan.ListExts.
Require Genevan.ProtoPeer.Peer.
Require Genevan.ProtoPeer.CollectionT.
Require Genevan.ProtoPeer.CollectionOfProtocolsT.

(** A concrete implementation of the _CollectionOfProtocolsT_ interface. *)

Module CollectionOfProtocols
  (A     : Peer.T)
  (ASets : Peer.SetsT A)
  (AC    : CollectionT.S A ASets)
  (B     : Peer.T)
  (BSets : Peer.SetsT B)
  (BC    : CollectionT.S B BSets)
: CollectionOfProtocolsT.S A ASets AC B BSets BC.

  Module AF := FSetFacts.WFacts ASets.
  Module BF := FSetFacts.WFacts BSets.

  Record t := {
    peersA : ASets.t;
    peersB : BSets.t
  }.

  Definition setsHaveName (ps : t) (n : ProtoName.t) : Prop :=
    AC.setsHaveName (peersA ps) n /\ BC.setsHaveName (peersB ps) n.

  Definition setsEitherNonEmpty (ps : t) : Prop :=
    AC.setsNonEmpty (peersA ps) \/ BC.setsNonEmpty (peersB ps).

  Definition setsWF (ps : t) (n : ProtoName.t) : Prop :=
    setsHaveName ps n /\ setsEitherNonEmpty ps.

  Module ByName      := ProtoName.Maps.
  Module ByNameFacts := ProtoName.MapsFacts.

  Definition mapWF (m : ByName.t t) : Prop :=
    forall s n, ByName.MapsTo n s m -> setsWF s n.

  Definition mapInA (e : A.t) (m : ByName.t t) : Prop :=
    exists s, ByName.MapsTo (ProtoIdentifier.name (A.supports e)) s m /\ ASets.In e (peersA s).

  Definition mapInB (e : B.t) (m : ByName.t t) : Prop :=
    exists s, ByName.MapsTo (ProtoIdentifier.name (B.supports e)) s m /\ BSets.In e (peersB s).

  Theorem mapWFEmpty : mapWF (ByName.empty t).
  Proof.
    unfold mapWF.
    intros s n H_m.
    rewrite ProtoName.MapsFacts.empty_mapsto_iff in H_m.
    contradiction.
  Qed.

  Theorem mapInAEmptyFalse : forall a, ~mapInA a (ByName.empty t).
  Proof.
    unfold mapInA.
    intros a.
    unfold not; intro H_contra.
    destruct H_contra as [x [Hc0 Hc1]].
    rewrite ProtoName.MapsFacts.empty_mapsto_iff in Hc0.
    exact Hc0.
  Qed.

  Theorem mapInBEmptyFalse : forall a, ~mapInB a (ByName.empty t).
  Proof.
    unfold mapInB.
    intros b.
    unfold not; intro H_contra.
    destruct H_contra as [x [Hc0 Hc1]].
    rewrite ProtoName.MapsFacts.empty_mapsto_iff in Hc0.
    exact Hc0.
  Qed.

  Definition singletonAT (a : A.t) : t :=
    Build_t (ASets.singleton a) BSets.empty.

  Theorem setsHaveNameSingletonAT : forall a,
    setsHaveName (singletonAT a) (ProtoIdentifier.name (A.supports a)).
  Proof.
    intros a.
    constructor. {
      apply AC.setsHaveNameSingleton.
    } {
      hnf.
      unfold singletonAT.
      intros x H_false.
      simpl in H_false.
      rewrite BF.empty_iff in H_false.
      contradiction.
    }
  Qed.

  Theorem setsEitherNonEmptySingletonAT : forall a,
    setsEitherNonEmpty (singletonAT a).
  Proof.
    intros a.
    unfold singletonAT.
    unfold setsEitherNonEmpty.
    unfold AC.setsNonEmpty.
    left.
    simpl.
    unfold not; intro H_contra.
    unfold ASets.Empty in H_contra.
    assert (ASets.In a (ASets.singleton a)) as H_in
      by (apply ASets.singleton_2; reflexivity).
    pose proof (H_contra a).
    contradiction.
  Qed.

  Theorem setsWFSingletonAT : forall a,
    setsWF (singletonAT a) (ProtoIdentifier.name (A.supports a)).
  Proof.
    constructor.
    apply setsHaveNameSingletonAT.
    apply setsEitherNonEmptySingletonAT.
  Qed.

  Definition singletonBT (b : B.t) : t :=
    Build_t ASets.empty (BSets.singleton b).

  Theorem setsHaveNameSingletonBT : forall b,
    setsHaveName (singletonBT b) (ProtoIdentifier.name (B.supports b)).
  Proof.
    intros b.
    constructor. {
      hnf.
      unfold singletonAT.
      intros x H_false.
      simpl in H_false.
      rewrite AF.empty_iff in H_false.
      contradiction.
    } {
      apply BC.setsHaveNameSingleton.
    }
  Qed.

  Theorem setsEitherNonEmptySingletonBT : forall b,
    setsEitherNonEmpty (singletonBT b).
  Proof.
    intros b.
    unfold singletonBT.
    unfold setsEitherNonEmpty.
    unfold BC.setsNonEmpty.
    right.
    simpl.
    unfold not; intro H_contra.
    unfold BSets.Empty in H_contra.
    assert (BSets.In b (BSets.singleton b)) as H_in
      by (apply BSets.singleton_2; reflexivity).
    pose proof (H_contra b).
    contradiction.
  Qed.

  Theorem setsWFSingletonBT : forall b,
    setsWF (singletonBT b) (ProtoIdentifier.name (B.supports b)).
  Proof.
    constructor.
    apply setsHaveNameSingletonBT.
    apply setsEitherNonEmptySingletonBT.
  Qed.

  Definition addPeerAT (ps : t) (a : A.t) : t :=
    Build_t (ASets.add a (peersA ps)) (peersB ps).

  Theorem setsHaveNameAddPeerAT : forall ps a n,
    setsHaveName ps n ->
      ProtoIdentifier.name (A.supports a) = n ->
        setsHaveName (addPeerAT ps a) n.
  Proof.
    unfold setsHaveName.
    unfold AC.setsHaveName.
    unfold ASets.For_all.
    unfold addPeerAT.
    simpl in *.
    intros ps a n [H_hnL H_hnR] H_neq.
    constructor. {
      intros x H_inX.
      destruct (A.eq_dec a x) as [H_eqax|H_neqax]. {
        subst x.
        exact H_neq.
      } {
        rewrite AF.add_neq_iff in H_inX.
        apply (H_hnL x H_inX).
        unfold not; intro H_contra.
        rewrite H_contra in H_neqax.
        contradict H_neqax; reflexivity.
      }
    } {
      exact H_hnR.
    }
  Qed.

  Theorem setsEitherNonEmptyAddPeerAT : forall ps a,
    setsEitherNonEmpty ps -> setsEitherNonEmpty (addPeerAT ps a).
  Proof.
    unfold setsEitherNonEmpty.
    unfold AC.setsNonEmpty.
    unfold BC.setsNonEmpty.
    unfold ASets.Empty.
    simpl.
    intros ps a [H_ane|H_bne]. {
      left.
      unfold not; intro H_contra.
      pose proof (H_contra a) as H_contra2.
      apply H_contra2.
      apply ASets.add_1.
      reflexivity.
    } {
      right; trivial.
    }
  Qed.

  Theorem setsWFAddPeerAT : forall ps a n,
    setsWF ps n ->
      ProtoIdentifier.name (A.supports a) = n ->
        setsWF (addPeerAT ps a) n.
  Proof.
    intros ps a n [H_wf0L H_wf0R] H_neq.
    constructor. {
      apply setsHaveNameAddPeerAT.
      exact H_wf0L.
      exact H_neq.
    } {
      apply setsEitherNonEmptyAddPeerAT.
      exact H_wf0R.
    }
  Qed.

  Definition addPeerBT (ps : t) (b : B.t) : t :=
    Build_t (peersA ps) (BSets.add b (peersB ps)).

  Theorem setsHaveNameAddPeerBT : forall ps b n,
    setsHaveName ps n ->
      ProtoIdentifier.name (B.supports b) = n ->
        setsHaveName (addPeerBT ps b) n.
  Proof.
    unfold setsHaveName.
    unfold BC.setsHaveName.
    unfold BSets.For_all.
    unfold addPeerBT.
    simpl in *.
    intros ps b n [H_hnL H_hnR] H_neq.
    constructor. {
      exact H_hnL.
    } {
      intros x H_inX.
      destruct (B.eq_dec b x) as [H_eqax|H_neqax]. {
        subst x.
        exact H_neq.
      } {
        rewrite BF.add_neq_iff in H_inX.
        apply (H_hnR x H_inX).
        unfold not; intro H_contra.
        rewrite H_contra in H_neqax.
        contradict H_neqax; reflexivity.
      }
    }
  Qed.

  Theorem setsEitherNonEmptyAddPeerBT : forall ps b,
    setsEitherNonEmpty ps -> setsEitherNonEmpty (addPeerBT ps b).
  Proof.
    unfold setsEitherNonEmpty.
    unfold AC.setsNonEmpty.
    unfold BC.setsNonEmpty.
    unfold ASets.Empty.
    simpl.
    intros ps b [H_ane|H_bne]. {
      left; trivial.
    } {
      right.
      unfold not; intro H_contra.
      pose proof (H_contra b) as H_contra2.
      apply H_contra2.
      apply BSets.add_1.
      reflexivity.
    }
  Qed.

  Theorem setsWFAddPeerBT : forall ps b n,
    setsWF ps n ->
      ProtoIdentifier.name (B.supports b) = n ->
        setsWF (addPeerBT ps b) n.
  Proof.
    intros ps b n [H_wf0L H_wf0R] H_neq.
    constructor. {
      apply setsHaveNameAddPeerBT.
      exact H_wf0L.
      exact H_neq.
    } {
      apply setsEitherNonEmptyAddPeerBT.
      exact H_wf0R.
    }
  Qed.

  Theorem addBPreservesA : forall ps a b,
    ASets.In a (peersA ps) -> ASets.In a (peersA (addPeerBT ps b)).
  Proof. intros; auto. Qed.

  Theorem addAPreservesB : forall ps a b,
    BSets.In b (peersB ps) -> BSets.In b (peersB (addPeerAT ps a)).
  Proof. intros; auto. Qed.

  Definition addPeerA
    (e : A.t)
    (m : ByName.t t)
  : ByName.t t :=
    let name := ProtoIdentifier.name (A.supports e) in
      match ByName.find name m with
      | Some ex => ByName.add name (addPeerAT ex e) m
      | None    => ByName.add name (singletonAT e) m
      end.

  Theorem mapWFAddPeerA : forall (m : ByName.t t) (e : A.t),
    mapWF m -> mapWF (addPeerA e m).
  Proof.
    unfold mapWF.
    unfold addPeerA.
    intros m e H_wf.
    remember (ProtoIdentifier.name (A.supports e)) as e_name.
    intros s n H_mapsA.

    destruct (ByName.find e_name m) as [ex|] eqn:H_find. {
      rewrite <- ByNameFacts.find_mapsto_iff in H_find.
      rewrite ByNameFacts.add_mapsto_iff in H_mapsA.
      destruct H_mapsA as [[HL0 HL1]|[HR0 HR1]]. {
        rewrite <- HL0 in *.
        rewrite <- HL1.
        pose proof (H_wf _ _ H_find) as H_prevWF.
        symmetry in Heqe_name.
        apply (setsWFAddPeerAT _ _ _ H_prevWF Heqe_name).
      } {
        apply (H_wf _ _ HR1).
      }
    } {
      rewrite ByNameFacts.add_mapsto_iff in H_mapsA.
      destruct H_mapsA as [[HL0 HL1]|[HR0 HR1]]. {
        rewrite <- HL0 in *.
        rewrite <- HL1.
        rewrite Heqe_name.
        apply (setsWFSingletonAT e).
      } {
        apply (H_wf _ _ HR1).
      }
    }
  Qed.

  Theorem mapInAddPeerA : forall (m : ByName.t t) (e : A.t),
    mapInA e (addPeerA e m).
  Proof.
    unfold mapInA.
    unfold addPeerA.
    intros m e.
    remember (ProtoIdentifier.name (A.supports e)) as e_name.
    destruct (ByName.find e_name m) as [ex|] eqn:H_find. {
      rewrite <- ByNameFacts.find_mapsto_iff in H_find.
      unfold addPeerAT.
      simpl.
      exists (Build_t (ASets.add e (peersA ex)) (peersB ex)).
      constructor. {
        apply ByName.add_1; reflexivity.
      } {
        apply ASets.add_1.
        reflexivity.
      }
    } {
      unfold singletonAT.
      exists (Build_t (ASets.singleton e) BSets.empty).
      constructor. {
        apply ByName.add_1; reflexivity.
      } {
        apply ASets.singleton_2; reflexivity.
      }
    }
  Qed.

  Theorem mapAddPeerAPreservesA : forall (m : ByName.t t) (e f : A.t),
    mapInA f m -> mapInA f (addPeerA e m).
  Proof.
    intros m e f H_m.
    remember (ProtoIdentifier.name (A.supports f)) as f_name.
    remember (ProtoIdentifier.name (A.supports e)) as e_name.

    destruct (A.eq_dec e f) as [H_efEq|H_efNeq]. {
      subst f.
      apply mapInAddPeerA.
    } {
      destruct (String.string_dec e_name f_name) as [H_efnEq|H_efnNeq]. {
        unfold mapInA in *.
        unfold addPeerA.
        rewrite <- Heqf_name in *.
        rewrite <- Heqe_name in *.
        rewrite <- H_efnEq in *.
        destruct (ByName.find e_name m) as [sBefore|] eqn:H_find. {
          rewrite <- ByNameFacts.find_mapsto_iff in H_find.
          destruct H_m as [sx [H_sx0 H_sx1]].
          pose proof (ByNameFacts.MapsTo_fun H_find H_sx0) as H_same.
          subst sx.
          exists (addPeerAT sBefore e).
          constructor. {
            rewrite ByNameFacts.add_mapsto_iff.
            constructor. {
              constructor; reflexivity.
            }
          } {
            unfold addPeerAT.
            apply ASets.add_2.
            exact H_sx1.
          }
        } {
          destruct H_m as [sx [H_sx0 H_sx1]].
          pose proof (ByName.find_1 H_sx0) as H_contra.
          rewrite H_find in H_contra.
          inversion H_contra.
        }
      } {
        unfold mapInA in *.
        unfold addPeerA.
        rewrite <- Heqf_name in *.
        rewrite <- Heqe_name in *.
        destruct H_m as [sx [H_sx0 H_sx1]].
        exists sx.

        constructor. {
          destruct (ByName.find e_name m) as [sBefore|] eqn:H_find. {
            apply ByName.add_2.
            exact H_efnNeq.
            exact H_sx0.
          } {
            apply ByName.add_2.
            exact H_efnNeq.
            exact H_sx0.
          }
        } {
          exact H_sx1.
        }
      }
    }
  Qed.

  Definition addPeerB
    (e : B.t)
    (m : ByName.t t)
  : ByName.t t :=
    let name := ProtoIdentifier.name (B.supports e) in
      match ByName.find name m with
      | Some ex => ByName.add name (addPeerBT ex e) m
      | None    => ByName.add name (singletonBT e) m
      end.

  Theorem mapInAddPeerB : forall (m : ByName.t t) (e : B.t),
    mapInB e (addPeerB e m).
  Proof.
    unfold mapInB.
    unfold addPeerB.
    intros m e.
    remember (ProtoIdentifier.name (B.supports e)) as e_name.
    destruct (ByName.find e_name m) as [ex|] eqn:H_find. {
      rewrite <- ByNameFacts.find_mapsto_iff in H_find.
      unfold addPeerBT.
      simpl.
      exists (Build_t (peersA ex) (BSets.add e (peersB ex))).
      constructor. {
        apply ByName.add_1; reflexivity.
      } {
        apply BSets.add_1.
        reflexivity.
      }
    } {
      unfold singletonBT.
      exists (Build_t ASets.empty (BSets.singleton e)).
      constructor. {
        apply ByName.add_1; reflexivity.
      } {
        apply BSets.singleton_2; reflexivity.
      }
    }
  Qed.

  Theorem mapAddPeerBPreservesB : forall (m : ByName.t t) (e f : B.t),
    mapInB f m -> mapInB f (addPeerB e m).
  Proof.
    intros m e f H_m.
    remember (ProtoIdentifier.name (B.supports f)) as f_name.
    remember (ProtoIdentifier.name (B.supports e)) as e_name.

    destruct (B.eq_dec e f) as [H_efEq|H_efNeq]. {
      subst f.
      apply mapInAddPeerB.
    } {
      destruct (String.string_dec e_name f_name) as [H_efnEq|H_efnNeq]. {
        unfold mapInB in *.
        unfold addPeerB.
        rewrite <- Heqf_name in *.
        rewrite <- Heqe_name in *.
        rewrite <- H_efnEq in *.
        destruct (ByName.find e_name m) as [sBefore|] eqn:H_find. {
          rewrite <- ByNameFacts.find_mapsto_iff in H_find.
          destruct H_m as [sx [H_sx0 H_sx1]].
          pose proof (ByNameFacts.MapsTo_fun H_find H_sx0) as H_same.
          subst sx.
          exists (addPeerBT sBefore e).
          constructor. {
            rewrite ByNameFacts.add_mapsto_iff.
            constructor. {
              constructor; reflexivity.
            }
          } {
            unfold addPeerBT.
            apply BSets.add_2.
            exact H_sx1.
          }
        } {
          destruct H_m as [sx [H_sx0 H_sx1]].
          pose proof (ByName.find_1 H_sx0) as H_contra.
          rewrite H_find in H_contra.
          inversion H_contra.
        }
      } {
        unfold mapInB in *.
        unfold addPeerB.
        rewrite <- Heqf_name in *.
        rewrite <- Heqe_name in *.
        destruct H_m as [sx [H_sx0 H_sx1]].
        exists sx.

        constructor. {
          destruct (ByName.find e_name m) as [sBefore|] eqn:H_find. {
            apply ByName.add_2.
            exact H_efnNeq.
            exact H_sx0.
          } {
            apply ByName.add_2.
            exact H_efnNeq.
            exact H_sx0.
          }
        } {
          exact H_sx1.
        }
      }
    }
  Qed.

  Theorem mapWFAddPeerB : forall (m : ByName.t t) (e : B.t),
    mapWF m -> mapWF (addPeerB e m).
  Proof.
    unfold mapWF.
    unfold addPeerB.
    intros m e H_wf.
    remember (ProtoIdentifier.name (B.supports e)) as e_name.
    intros s n H_mapsA.

    destruct (ByName.find e_name m) as [ex|] eqn:H_find. {
      rewrite <- ByNameFacts.find_mapsto_iff in H_find.
      rewrite ByNameFacts.add_mapsto_iff in H_mapsA.
      destruct H_mapsA as [[HL0 HL1]|[HR0 HR1]]. {
        rewrite <- HL0 in *.
        rewrite <- HL1.
        pose proof (H_wf _ _ H_find) as H_prevWF.
        symmetry in Heqe_name.
        apply (setsWFAddPeerBT _ _ _ H_prevWF Heqe_name).
      } {
        apply (H_wf _ _ HR1).
      }
    } {
      rewrite ByNameFacts.add_mapsto_iff in H_mapsA.
      destruct H_mapsA as [[HL0 HL1]|[HR0 HR1]]. {
        rewrite <- HL0 in *.
        rewrite <- HL1.
        rewrite Heqe_name.
        apply (setsWFSingletonBT e).
      } {
        apply (H_wf _ _ HR1).
      }
    }
  Qed.

  Theorem mapAddPeerAPreservesB : forall (m : ByName.t t) (e : A.t) (f : B.t),
    mapInB f m -> mapInB f (addPeerA e m).
  Proof.
    intros m e f H_in.
    unfold addPeerA.
    remember (ProtoIdentifier.name (A.supports e)) as e_name.
    remember (ProtoIdentifier.name (B.supports f)) as f_name.

    destruct (String.string_dec e_name f_name) as [H_nameEq|H_nameNeq]. {
      destruct H_in as [s [H_inL H_inR]].
      unfold mapInB.
      subst f_name.
      rewrite <- H_nameEq in *.
      destruct (ByName.find e_name m) as [ex|] eqn:H_find. {
        rewrite <- ByNameFacts.find_mapsto_iff in H_find.
        assert (s = ex) as H_exs by (apply (ByNameFacts.MapsTo_fun H_inL H_find)).
        subst ex.
        exists (addPeerAT s e).
        constructor. {
          apply ByName.add_1; reflexivity.
        } {
          exact H_inR.
        }
      } {
        rewrite ByNameFacts.find_mapsto_iff in H_inL.
        rewrite H_inL in H_find.
        inversion H_find.
      }
    } {
      destruct H_in as [s [H_inL H_inR]].
      exists s.
      destruct (ByName.find e_name m) as [ex|] eqn:H_find. {
        constructor. {
          apply ByName.add_2.
          rewrite <- Heqf_name.
          auto.
          auto.
        } {
          exact H_inR.
        }
      } {
        constructor. {
          apply ByName.add_2.
          rewrite <- Heqf_name.
          auto.
          auto.
        } {
          exact H_inR.
        }
      }
    }
  Qed.

  Theorem mapAddPeerBPreservesA : forall (m : ByName.t t) (e : B.t) (f : A.t),
    mapInA f m -> mapInA f (addPeerB e m).
  Proof.
    intros m e f H_in.
    unfold addPeerB.
    remember (ProtoIdentifier.name (B.supports e)) as e_name.
    remember (ProtoIdentifier.name (A.supports f)) as f_name.

    destruct (String.string_dec e_name f_name) as [H_nameEq|H_nameNeq]. {
      destruct H_in as [s [H_inL H_inR]].
      unfold mapInA.
      subst f_name.
      rewrite <- H_nameEq in *.
      destruct (ByName.find e_name m) as [ex|] eqn:H_find. {
        rewrite <- ByNameFacts.find_mapsto_iff in H_find.
        assert (s = ex) as H_exs by (apply (ByNameFacts.MapsTo_fun H_inL H_find)).
        subst ex.
        exists (addPeerBT s e).
        constructor. {
          apply ByName.add_1; reflexivity.
        } {
          exact H_inR.
        }
      } {
        rewrite ByNameFacts.find_mapsto_iff in H_inL.
        rewrite H_inL in H_find.
        inversion H_find.
      }
    } {
      destruct H_in as [s [H_inL H_inR]].
      exists s.
      destruct (ByName.find e_name m) as [ex|] eqn:H_find. {
        constructor. {
          apply ByName.add_2.
          rewrite <- Heqf_name.
          auto.
          auto.
        } {
          exact H_inR.
        }
      } {
        constructor. {
          apply ByName.add_2.
          rewrite <- Heqf_name.
          auto.
          auto.
        } {
          exact H_inR.
        }
      }
    }
  Qed.

  Definition addPeersA
    (es : list A.t)
    (m  : ByName.t t)
  : ByName.t t :=
    List.fold_right addPeerA m es.

  Theorem mapWFAddPeersA : forall (m : ByName.t t) (es : list A.t),
    mapWF m -> mapWF (addPeersA es m).
  Proof.
    intros m es.
    induction es as [|x xs]. {
      auto.
    } {
      intro H_m.
      simpl.
      apply mapWFAddPeerA.
      apply IHxs.
      exact H_m.
    }
  Qed.

  Theorem mapInAddPeersA : forall (m : ByName.t t) (es : list A.t),
    forall e, List.In e es -> mapInA e (addPeersA es m).
  Proof.
    intros m es.
    induction es as [|x xs]. {
      intros e H_nil.
      inversion H_nil.
    } {
      intros e H_in.
      simpl.
      destruct H_in as [H_inL|H_inR]. {
        subst x.
        apply mapInAddPeerA.
      } {
        apply mapAddPeerAPreservesA.
        apply (IHxs e H_inR).
      }
    }
  Qed.

  Definition addPeersB
    (es : list B.t)
    (m  : ByName.t t)
  : ByName.t t :=
    List.fold_right addPeerB m es.

  Theorem mapWFAddPeersB : forall (m : ByName.t t) (es : list B.t),
    mapWF m -> mapWF (addPeersB es m).
  Proof.
    intros m es.
    induction es as [|x xs]. {
      auto.
    } {
      intro H_m.
      simpl.
      apply mapWFAddPeerB.
      apply IHxs.
      exact H_m.
    }
  Qed.

  Theorem mapInAddPeersB : forall (m : ByName.t t) (es : list B.t),
    forall e, List.In e es -> mapInB e (addPeersB es m).
  Proof.
    intros m es.
    induction es as [|x xs]. {
      intros e H_nil.
      inversion H_nil.
    } {
      intros e H_in.
      simpl.
      destruct H_in as [H_inL|H_inR]. {
        subst x.
        apply mapInAddPeerB.
      } {
        apply mapAddPeerBPreservesB.
        apply (IHxs e H_inR).
      }
    }
  Qed.

  Theorem mapAddPeersAPreservesB : forall (m : ByName.t t) (es : list A.t) f,
    mapInB f m -> mapInB f (addPeersA es m).
  Proof.
    intros m es.
    induction es as [|x xs]. {
      intros f H_mIn.
      exact H_mIn.
    } {
      intros f H_mIn.
      simpl.
      apply mapAddPeerAPreservesB.
      apply IHxs.
      exact H_mIn.
    }
  Qed.

  Theorem mapAddPeersBPreservesA : forall (m : ByName.t t) (es : list B.t) f,
    mapInA f m -> mapInA f (addPeersB es m).
  Proof.
    intros m es.
    induction es as [|x xs]. {
      intros f H_mIn.
      exact H_mIn.
    } {
      intros f H_mIn.
      simpl.
      apply mapAddPeerBPreservesA.
      apply IHxs.
      exact H_mIn.
    }
  Qed.

  Theorem mapAddPeersAPreservesA : forall (m : ByName.t t) (es : list A.t) e,
    mapInA e m -> mapInA e (addPeersA es m).
  Proof.
    intros m es.
    induction es as [|x xs]. {
      intros f H_mIn.
      exact H_mIn.
    } {
      intros f H_mIn.
      simpl.
      apply mapAddPeerAPreservesA.
      apply IHxs.
      exact H_mIn.
    }
  Qed.

  Theorem mapAddPeersBPreservesB : forall (m : ByName.t t) (es : list B.t) e,
    mapInB e m -> mapInB e (addPeersB es m).
  Proof.
    intros m es.
    induction es as [|x xs]. {
      intros f H_mIn.
      exact H_mIn.
    } {
      intros f H_mIn.
      simpl.
      apply mapAddPeerBPreservesB.
      apply IHxs.
      exact H_mIn.
    }
  Qed.

  Definition addPeersSA
    (es : ASets.t)
    (m  : ByName.t t)
  : ByName.t t :=
    addPeersA (ASets.elements es) m.

  Theorem mapWFAddPeersSA : forall (m : ByName.t t) (es : ASets.t),
    mapWF m -> mapWF (addPeersSA es m).
  Proof.
    unfold addPeersSA.
    intros m es H_m.
    apply (mapWFAddPeersA _ _ H_m).
  Qed.

  Theorem mapInAddPeersSA : forall (m : ByName.t t) (es : ASets.t),
    forall e, ASets.In e es -> mapInA e (addPeersSA es m).
  Proof.
    intros m es e H_in.
    pose proof (ASets.elements_1 H_in) as H_sL.
    apply mapInAddPeersA.
    apply ListExts.InA_In.
    exact H_sL.
  Qed.

  Definition addPeersSB
    (es : BSets.t)
    (m  : ByName.t t)
  : ByName.t t :=
    addPeersB (BSets.elements es) m.

  Theorem mapWFAddPeersSB : forall (m : ByName.t t) (es : BSets.t),
    mapWF m -> mapWF (addPeersSB es m).
  Proof.
    unfold addPeersSB.
    intros m es H_m.
    apply (mapWFAddPeersB _ _ H_m).
  Qed.

  Theorem mapInAddPeersSB : forall (m : ByName.t t) (es : BSets.t),
    forall e, BSets.In e es -> mapInB e (addPeersSB es m).
  Proof.
    intros m es e H_in.
    pose proof (BSets.elements_1 H_in) as H_sL.
    apply mapInAddPeersB.
    apply ListExts.InA_In.
    exact H_sL.
  Qed.

  Theorem mapInAddPeersSAPreservesB : forall (m : ByName.t t) es f,
    mapInB f m -> mapInB f (addPeersSA es m).
  Proof.
    intros m es f H_minB.
    unfold addPeersSA.
    apply mapAddPeersAPreservesB.
    exact H_minB.
  Qed.

  Theorem mapInAddPeersSBPreservesA : forall (m : ByName.t t) es f,
    mapInA f m -> mapInA f (addPeersSB es m).
  Proof.
    intros m es f H_minA.
    unfold addPeersSB.
    apply mapAddPeersBPreservesA.
    exact H_minA.
  Qed.

  Lemma mapsToIn : forall (A : Type) (v : A) m k,
    ByName.MapsTo k v m -> List.In (k, v) (ByName.elements m).
  Proof.
    intros A v m k H_maps.
    rewrite ByNameFacts.elements_mapsto_iff in H_maps.
    induction H_maps as [p ps [HK0 HK1]|p ps HR]. {
      left.
      assert (fst p = k) as H_eqK
        by (rewrite HK0; reflexivity).
      assert (snd p = v) as H_eqV
        by (rewrite <- HK1; reflexivity).
      rewrite <- H_eqK.
      rewrite <- H_eqV.
      destruct p; reflexivity.
    } {
      right.
      exact IHHR.
    }
  Qed.

  Theorem mapAddPeersSAPreservesA : forall (m : ByName.t t) oSet f,
    mapInA f m -> mapInA f (addPeersSA oSet m).
  Proof.
    intros m oSet f H_minA.
    unfold addPeersSA.
    apply mapAddPeersAPreservesA.
    exact H_minA.
  Qed.

  Theorem mapInAddPeersSBPreservesB : forall (m : ByName.t t) oSet f,
    mapInB f m -> mapInB f (addPeersSB oSet m).
  Proof.
    intros m oSet f H_minB.
    unfold addPeersSB.
    apply mapAddPeersBPreservesB.
    exact H_minB.
  Qed.

  Definition collectProtocols
    (ma : ByName.t ASets.t)
    (mb : ByName.t BSets.t)
  : ByName.t t :=
    let init := ByName.empty t                    in
    let aes  := List.map snd (ByName.elements ma) in
    let bes  := List.map snd (ByName.elements mb) in
    let mwa  := List.fold_right addPeersSA init aes in
      List.fold_right addPeersSB mwa bes.

  Lemma collectProtocolsAL : forall (ma : ByName.t ASets.t) es,
    mapWF (List.fold_right addPeersSA (ByName.empty t) es).
  Proof.
    intros ma.
    induction es as [|y ys]. {
      apply mapWFEmpty.
    } {
      simpl.
      apply mapWFAddPeersSA.
      auto.
    }
  Qed.

  Lemma collectProtocolsBL : forall es m (ma : ByName.t BSets.t),
    mapWF m -> mapWF (List.fold_right addPeersSB m es).
  Proof.
    intros es.
    induction es as [|y ys]. {
      intros m mb H_mwf.
      exact H_mwf.
    } {
      intros m mb H_mwf.
      simpl.
      apply mapWFAddPeersSB.
      auto.
    }
  Qed.

  Theorem collectProtocolsWF : forall ma mb, mapWF (collectProtocols ma mb).
  Proof.
    intros ma mb.
    unfold collectProtocols.
    apply collectProtocolsBL; auto.
    apply collectProtocolsAL; auto.
  Qed.

  Theorem collectProtocolsInAL : forall ma a m,
    AC.mapIn a ma ->
      mapInA a (List.fold_right addPeersSA m (List.map snd (ByName.elements ma))).
  Proof.
    intros ma a m H_min.
    destruct H_min as [xSet [H_min0 H_min1]].
    pose proof (mapsToIn _ _ _ _ H_min0) as H_in0.
    pose proof (ListExts.InMapPair _ _ _ _ _ H_in0) as [H_in1 H_in2].
    clear H_in0.
    clear H_in1.

    induction (List.map snd (ByName.elements ma)) as [|ySet rSets]. {
      inversion H_in2.
    } {
      destruct H_in2 as [H_in0|H_in1]. {
        subst.
        apply mapInAddPeersSA.
        exact H_min1.
      } {
        pose proof (IHrSets H_in1) as H_inRsets.
        apply mapAddPeersSAPreservesA.
        exact H_inRsets.
      }
    }
  Qed.

  Theorem collectProtocolsInBL : forall mb b m,
    BC.mapIn b mb ->
      mapInB b (List.fold_right addPeersSB m (List.map snd (ByName.elements mb))).
  Proof.
    intros mb b m H_min.
    destruct H_min as [xSet [H_min0 H_min1]].
    pose proof (mapsToIn _ _ _ _ H_min0) as H_in0.
    pose proof (ListExts.InMapPair _ _ _ _ _ H_in0) as [H_in1 H_in2].
    clear H_in0.
    clear H_in1.

    induction (List.map snd (ByName.elements mb)) as [|ySet rSets]. {
      inversion H_in2.
    } {
      destruct H_in2 as [H_in0|H_in1]. {
        subst.
        apply mapInAddPeersSB.
        exact H_min1.
      } {
        pose proof (IHrSets H_in1) as H_inRsets.
        apply mapInAddPeersSBPreservesB.
        exact H_inRsets.
      }
    }
  Qed.

  Theorem collectProtocolsInALPB : forall m a es,
    mapInA a m -> mapInA a (List.fold_right addPeersSB m es).
  Proof.
    induction es as [|y ys]. {
      intros H_in; exact H_in.
    } {
      intros H_in.
      simpl.
      apply mapInAddPeersSBPreservesA.
      apply IHys.
      exact H_in.
    }
  Qed.

  Theorem collectProtocolsInA : forall ma mb (a : A.t),
    AC.mapIn a ma -> mapInA a (collectProtocols ma mb).
  Proof.
    intros ma mb a H_inA.
    destruct H_inA as [s [H_in0 H_in1]].
    unfold collectProtocols.
    apply collectProtocolsInALPB.
    apply collectProtocolsInAL.
    exists s; auto.
  Qed.

  Theorem collectProtocolsInB : forall ma mb (b : B.t),
    BC.mapIn b mb -> mapInB b (collectProtocols ma mb).
  Proof.
    intros ma mb b H_inB.
    destruct H_inB as [s [H_in0 H_in1]].
    unfold collectProtocols.
    apply collectProtocolsInBL.
    exists s; auto.
  Qed.

End CollectionOfProtocols.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University

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

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

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  Ifnot, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export computation8.

Lemma hasvaluec_computes_to_valc_implies {o} :
  forall lib (a : @CTerm o),
    hasvaluec lib a -> {b : CTerm & computes_to_valc lib a b}.
Proof.
  introv hv; destruct_cterms; unfold hasvaluec in hv; allsimpl.
  unfold hasvalue in hv; exrepnd.
  unfold computes_to_value in hv0; repnd.
  applydup @isvalue_implies in hv0; repnd.
  allrw @isprogram_eq.
  exists (mk_ct t' hv2).
  unfold computes_to_valc, computes_to_value; simpl; dands; auto.
Qed.


(*
Definition of the AM Monad + monadic helper functions.

Author:  Adam Petz, ampetz@ku.edu
*)
Require Import Maps GenStMonad Impl_vm StVM StAM.
Require Import Term ConcreteEvidence.

Require Import PeanoNat.

Require Import List.
Import ListNotations.

Definition AM := St AM_St.

Definition am_newNonce (bs :BS) : AM EvidenceC :=
  am_st <- get ;;
  let mm := am_nonceMap am_st in
  let i := am_nonceId am_st in
  let appm := st_aspmap am_st in
  let sigm := st_sigmap am_st in
  let hshm := st_hshmap am_st in
  let checkedm := checked am_st in
  let tracem := am_st_trace am_st in
  let newMap := map_set mm i bs in
  let newId := i + 1 in
  put (mkAM_St newMap newId appm sigm hshm tracem checkedm) ;;
  ret (nnc i bs mtc).

Definition getNonceVal (nid:nat) : AM BS :=
  m <- gets am_nonceMap ;;
  let maybeVal := map_get m nid in
  match maybeVal with
  | Some bs => ret bs
  | None => failm
  end.

Definition add_checked (nid:nat) : AM unit :=
  am_st <- get ;;
  let mm := am_nonceMap am_st in
  let i := am_nonceId am_st in
  let appm := st_aspmap am_st in
  let sigm := st_sigmap am_st in
  let hshm := st_hshmap am_st in
  let checkedm := checked am_st in
  let tracem := am_st_trace am_st in
  put (mkAM_St mm i appm sigm hshm tracem (checkedm ++ [nid])).

Definition am_checkNonce (nid:nat) (bs:BS) : AM BS :=
  good_bs <- getNonceVal nid ;;
  add_checked nid ;;
  if (Nat.eq_dec bs good_bs) then ret 1 else ret 0.

Definition nonces_checked (nm:MapC nat BS) (l:list nat) : Prop :=
  forall x,
  (exists v, bound_to nm x v) ->
  In x l.

Definition nonces_checked_st (st:AM_St) : Prop :=
  match st with
  | mkAM_St nm i am sm hm tr l =>
    nonces_checked nm l
  end.

Require Import StVM MonadVM.

(** * Helper functions for Appraisal *)

Definition checkSig (x:nat) (i:ASP_ID) (e':EvidenceC) (sig:BS) : CVM BS :=
  invokeUSM x i ([encodeEv e'] ++ [sig] (* ++ args*) ) 0 0 ;;
  ret x.

Definition checkUSM (x:nat) (i:ASP_ID) (l:list Arg) (tpl:Plc) (tid:TARG_ID) (bs:BS) : CVM BS :=
  invokeUSM x i ([bs] ++ l) tpl tid ;;
  ret x.

Definition hashEvT (e:Evidence): BS.
Admitted.

Definition checkHSH (*(x:nat) (i:ASP_ID) (l:list Arg) (tpl:Plc) (tid:TARG_ID)*)
           (e:Evidence) (bs:BS) : CVM BS :=
  invokeUSM 0 1 ([hashEvT e] ++ [bs]) 42 43 ;;
  ret 0.

Definition runAM {A:Type} (k:(AM A)) (st:AM_St) : (option A) * AM_St :=
  runSt k st.

Definition incNonce := runAM (am_newNonce 42) empty_amst.

Definition am_run_t (t:Term) (e:EvidenceC) (et:Evidence) : AM EvidenceC :=
  let annt := annotated t in
  let start_st := (mk_st e et [] 0) in
  ret (st_ev (run_cvm annt start_st)).

Definition am_run_t_anno (annt:AnnoTerm) (e:EvidenceC) (et:Evidence) : AM EvidenceC :=
  let start_st := (mk_st e et [] 0) in
  ret (st_ev (run_cvm annt start_st)).

(** * Helper functions for Appraisal *)

Definition am_get_app_asp (p:Plc) (i:ASP_ID) : AM ASP_ID :=
  m <- gets st_aspmap ;;
  let maybeId := map_get m (p,i) in
  match maybeId with
  | Some i' => ret i'
  | None => failm
  end.

Definition am_get_sig_asp (p:Plc) : AM ASP_ID :=
  m <- gets st_sigmap ;;
  let maybeId := map_get m p in
  match maybeId with
  | Some i' => ret i'
  | None => failm
  end.

(* ***  Extra  *** *)
(*
Definition t1 := (att 1 (lseq (asp (ASPC 44 [])) (asp SIG))).
Definition t2 := (lseq (asp (ASPC 44 [])) (asp SIG)).
*)

(*
Compute (am_run_t t2 mtc empty_amst).
*)

(*
Definition am_proto_1 :=
  n2 <- am_newNonce 42 ;;
    n <- am_newNonce 43 ;;
    am_run_t t2 n.
*)

(*
Compute (runAM am_proto_1 empty_amst).
*)

(*
Fixpoint nonces (e:EvidenceC) (l:list nat) : list nat :=
  match e with
  | nnc i _ e' => nonces e' ([i] ++ l)
  | _ => l
  end.
 *)


Require Import RefProofDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import RefTactics.
Require Import AbsAccessor.Spec.
Require Import RmiAux.Specs.init_common_sysregs.
Require Import RmiAux.LowSpecs.init_common_sysregs.
Require Import RmiAux.RefProof.RefRel.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Opaque Z.add Z.mul Z.div Z.shiftl Z.shiftr Z.land Z.lor.

Section Refine.

  Hint Unfold
       set_rec_common_sysregs_spec
       get_rd_g_rtt_spec
       granule_addr_spec
    .

  Lemma init_common_sysregs_spec_exists:
    forall habd habd'  labd rec rd
           (Hspec: init_common_sysregs_spec rec rd habd = Some habd')
            (Hrel: relate_RData habd labd),
    exists labd', init_common_sysregs_spec0 rec rd labd = Some labd' /\ relate_RData habd' labd'.
  Proof.
    Local Opaque ptr_eq.
    intros. destruct Hrel. inv id_rdata. destruct rec, rd.
    unfold init_common_sysregs_spec0, init_common_sysregs_spec in *.
    repeat autounfold in *.
    hsimpl_hyp Hspec; inv Hspec; simpl_query_oracle;
      extract_prop_dec; repeat destruct_con; repeat destruct_dis; bool_rel; simpl in *;
        repeat (simpl_htarget; grewrite; try solve_ptr_eq; try unfold ref_accessible in *; simpl in *).
    rewrite ZMap.gso.
    repeat (simpl_htarget; grewrite; simpl).
    repeat (solve_bool_range; grewrite).
    repeat simpl_field. repeat simpl_update_reg.
    eexists; (split; [reflexivity| constructor; reflexivity]).
    red; intro T; inv T; srewrite. inv C4.
  Qed.

End Refine.


(** This file was written by Colm Bhandal, PhD student, Foundations and Methods group,
School of Computer Science and Statistics, Trinity College, Dublin, Ireland.*)

(***************************** Standard Imports *****************************)

Require Import Equality.

Require Import ComhCoq.Extras.LibTactics.

(***************************** Specialised Imports *****************************)

Require Import ComhCoq.GenTacs.
Require Import ComhCoq.StandardResults.
Require Import ComhCoq.ComhBasics.
Require Import ComhCoq.LanguageFoundations.
Require Import ComhCoq.SoftwareLanguage.
Require Import ComhCoq.InterfaceLanguage.
Require Import ComhCoq.ModeStateLanguage.
Require Import ComhCoq.NetworkLanguage.
Require Import ComhCoq.ProtAuxDefs.
Require Import ComhCoq.ProtAuxResults.
Require Import ComhCoq.EntAuxDefs.
Require Import ComhCoq.EntAuxResults.
Require Import ComhCoq.NetAuxBasics.
Require Import ComhCoq.NetAuxDefs.
Require Import ComhCoq.NARMisc.

Open Scope R_scope.

(* If an entity has sent a message v t time units ago, and that time is less than the
message latency, then said message is in the output queue of the interface component
with timestamp mL - t.*)
Theorem sent_outgoing (n : Network) (v : list BaseType) (t : Time) (i : nat)
  (p : reachableNet n) :
  sent v t i n p -> forall q : t < msgLatency,
  outgoing v (minusTime msgLatency t (Rlt_le t msgLatency q)) i n.
  (**Proof: Induction on sent.*)
  intros. induction H.
  (*In the base case we have that h - ioProc<v>? -> h', where h is the interface of the entity
  in question. By analysing this interface transition we get that <v, mL> is at the head of the
  output list of I', and so is in this list*)
  invertClear H2.
  addHyp (outList_received_in l2 l2' v H5).
  (*and so we have outgoing v mL i n, which is our goal exactly since t = 0.*)
  econstructor. rewrite <- H6 in H0.
  apply H0. replace (minusTime msgLatency zeroTime (Rlt_le zeroTime msgLatency q))
  with msgLatency. apply H2. apply timeEqR. simpl. ring.
  (*In the discrete case for induction we apply the I.H.*)
  addHyp (IHsent q). clear IHsent.
  (*Since t hasn't changed we get outgoing v (mL - t) i n. We then observe that since
  t < mL, then 0 < mL - t*)
  remember (minusTime msgLatency t (Rlt_le t msgLatency q)) as t'.
  assert (0 < t'). rewrite Heqt'. simpl. apply RltMinusBothSides. assumption.
  (*and so by (NetAuxBasics::outgoing_disc_pres) the outgoing relation is preserved
  from the previous to the current state, giving outgoing v (mL - t) i n' as required.*)
  addHyp (outgoing_disc_pres n n' a v t' i w H0 H1). assumption.
  (*In the delay case for induction, we can immediately infer from  t + d < mL
  that t < mL and so outgoing v (mL - t) i n.*)
  simpl in q. assert (t < msgLatency). eapply Rplus_lt_weaken_lr. apply q. apply Rlt_le.
  delPos. addHyp (IHsent H0). clear IHsent.
  (*Then since n -d-> n', by (NetAuxBasics::outgoing_del) we get
  outgoing v (mL - t - d) i n = outgoing v (mL - (t + d)) i n, which is our goal exactly.*)
  remember (minusTime msgLatency t (Rlt_le t msgLatency H0)) as t'.
  addHyp (outgoing_del n n' d v t' i w H1). invertClear H2.
  replace (minusTime (nonneg (time msgLatency)) (nonneg (time (delToTime (t +dt+ d))))
  (Rlt_le (nonneg (time (delToTime (t +dt+ d)))) (nonneg (time msgLatency)) q)) with
  (minusTime t' d x). apply H3. clear H1 H3. generalize dependent x. rewrite Heqt'.
  intros. apply timeEqR. simpl. ring. Qed.

(*If an entity is nextSince m t, then <m, l0> was sent exactly t time units ago for some l0.*)
Theorem fst_sent (n : Network) (m : Mode) (t : Time) (i : nat)
  (p : reachableNet n) : nextSince m t i n p ->
  exists l0, sent [baseMode m, basePosition l0] t i n p.
(**Proof: By induction on nextSince.*)
  intros. induction H.
  (*In the base case, first off let's do some inversions*)
  state_pred_net_destr H0. state_pred_net_destr H1.
  (*Apply a linking tactic*)
  link_netentdisc_tac b.
  (*Eliminate the case of equal entities by inverting different state predicates.
  This is a hack, a proper tactic state_pred_elim_ent would be better but would
  take ages to write.*)
  state_pred_elim H2 H5. state_pred_elim H9 H10. state_pred_elim H9 H10.
  state_pred_elim H16 H12.
  (*Now we're left with the case where there is a transition from one entity to the other.
  Then we can add an entity-level tracking result. Tracking yields that the software component
  of the entity i outputs on io of <m, l0> which is complemented by an input of same by the
  interface of that entity.*)
  (*
  lets OOTE : ovReady_ovWait_track_ent H2 H5 H11. andflat OOT.
  (*Show that the position hasn't changed.*)
  ent_disc_pres_pos_tac. subst.
  (*We show that the network action must be a tau because the software
  term has changed.*)
  assert (p0 <> p1) as PNE. unfold not. intros. subst. state_pred_elim H7 H4.
  state_pred_elim H10 H8. lets PTN : procNeq_tau_net H3 H6 w PNE. subst.
  (*There is now enough information to prove the base case for sent, with t = 0. Hence we
  use l1 as our existential witness and satisfy the goal.*)
  exists l1. eapply sentBase; eassumption.
  (*In the inductive cases, we simply apply the inductive hypothesis and
  then the appropriate constructor of sent.*)
  invertClearAs2 IHnextSince l0 IH. exists l0. constructor.
  assumption.
  invertClearAs2 IHnextSince l0 IH. exists l0. constructor.
  assumption. Qed.*)
  Admitted. (*R*)

(* If an entity has sent a message v mL time units ago, then said message is in the output
queue of the interface component with timestamp 0 or it has been delivered 0 time units ago.*)
Theorem sent_out_del (n : Network) (v : list BaseType) (i : nat)
  (p : reachableNet n) : sent v msgLatency i n p ->
  outgoing v zeroTime i n \/
  exists r l, delivered ([-v, l, r-]) zeroTime i n p.
  (**Proof: By induction on sent.*)
  introz U. remember msgLatency as mL. induction U.
  (*The base case fails because it gives the contradiction mL = 0, while mL
  is assumed positive.*)
  false. eapply Rlt_not_le. apply msgLatency_positive. rewrite <- HeqmL.
  apply Rle_refl.
  (*For the discrete inductive case we get from the I.H. that either
  outgoing v 0 i n or delivered v r 0 i n.*)
  apply IHU in HeqmL. clear IHU. elim_intro HeqmL OZ EDZ.
  (*In the first case we know outgoing v 0 i n. In which case we can apply
  (Basics::outgoing_timeout_disc) to obtain our goal.*)
  (*First we just do a little bit of pocessing to explicitly get the entity
  and hence its position.*)
  lets OZX : OZ. inversion OZX.
  lets OTD : outgoing_timeout_disc OZ. or_flat.
  (*The left subcase immediatley gives the goal.*)
  left. eassumption.
  (*The right sub-case gives the RHS of the goal.*)
  ex_flat. right. exists x. exists l. eassumption.
  (*If the latter is true, then we can immediately show by constructor
  that delivered v r 0 i n'.*)
  right. ex_flat. exists x x0. constructor. assumption.
  (*Moving on to the timed case, where we get that t + d = mL and so
  t = mL - d < mL*)
  assert (t < msgLatency). rewrite <- HeqmL. simpl. Rplus_lt_tac.
  delPos.
  (*From here, by (sent_outgoing) we have outgoing v (mL - t) i n*)
  lets SO : sent_outgoing U H. left.
  (*Now, by some algebra and substituting for t using our recently deduced
  equality is the same as outgoing v d i n.*)
  assert (outgoing v d i n) as OD. my_applys_eq SO.
  apply timeEqR. simpl. rewrite <- HeqmL. simpl.
  destruct d. destruct delay. simpl. ring.
  (*Now we apply (Basics::outgoing_del)*)
  lets OGD : outgoing_del w OD. invertClear OGD.
  (*And we get a term equivalent to outgoing v 0 i n, as required.*)
  my_applys_eq H0. apply timeEqR. simpl. destruct d; destruct delay.
  simpl. ring. Qed.

(* If an entity has sent a message v t time units ago, and that time is greater than the
message latency, then said message was delivered to some radius, and the delivery time
is less than the time of sending by the amount message latency.*)
Theorem sent_delivered (n : Network) (v : list BaseType) (t : Time) (i : nat)
  (p : reachableNet n) : sent v t i n p -> forall q : msgLatency < t,
  exists r l,
  delivered ([-v, l, r-]) (minusTime t msgLatency (Rlt_le msgLatency t q)) i n p.
  (**Proof: Induction on sent. Well the base case can be immediately discarded due to the
  contradiction of t = 0 and mL < t, given that mL is positive.*)
  intros. induction H. contradict q. apply Rle_not_lt. simpl. timeNonneg.
  (*In the discrete inductive case, the time parameter does not change since the previous
  state, and so by the inductive hypothesis we have delivered v r (t - mL) i n*)
  addHyp (IHsent q). clear IHsent. decompose [ex] H0. clear H0. rename x0 into l.
  rename x into r.
  (*Then by the discrete constructor of delivered we have in this state
  delivered v r (t - mL) i n'.*)
  exists r. exists l. constructor. assumption.
  (*For the timed case, there are two subcases.*)
  addHyp (Rlt_or_le msgLatency t). invertClear H0.
  (*If mL < t, then by the inductive hypothesis and timed constructor of delivered we get
  our goal.*)
  addHyp (IHsent H1). clear IHsent. decompose [ex] H0. exists x. exists x0.
  replace (minusTime (nonneg (time (delToTime (t +dt+ d))))
  (nonneg (time msgLatency)) (Rlt_le (nonneg (time msgLatency))
  (nonneg (time (delToTime (t +dt+ d)))) q)) with
  (delToTime ((minusTime t msgLatency (Rlt_le msgLatency t H1)) +dt+ d)).
  apply deliveredDel. assumption. apply timeEqR. simpl. ring.
  (*Else, t <= mL. We split this again into t < mL and t = mL.*)
  apply Rle_lt_or_eq_dec in H1. invertClear H1.
  (*t < mL gives a contradiction. We achieve the contradiction by first applying
  (sent_outgoing) to get outgoing v (mL - t) i n.*)
  addHyp (sent_outgoing n v t i p H H0).
  (*Then we apply (NetAuxBasics::outgoing_del) to get d <= mL - t*)
  remember ((minusTime msgLatency t (Rlt_le t msgLatency H0))) as t'.
  addHyp (outgoing_del n n' d v t' i w H1).
  (*So t + d <= mL.*)
  invertClear H2. assert (t +dt+ d <= msgLatency). simpl. clear H3. rename x into Q.
  rewrite Heqt' in Q. simpl in Q.
  rewrite Rplus_comm. apply Rminus_le_swap_rr. assumption.
  (*But from our hypothesis we have mL < t + d, so we arrive at a contradiction.*)
  contradict q. apply Rle_not_lt. assumption.
  (*Thus we conclude t = mL and we can apply sent_out_del to our previous case, yielding
  outgoing v 0 i n \/ exists r, delivered v r 0 i n.*)
  apply timeEqR in H0. rewrite H0 in H. addHyp (sent_out_del n v i p H).
  invertClear H1.
  (*The LHS fails, again by contradiction via a corollary of (NetAuxBasics::outgoing_del)
  saying that t = 0 implies no delay is possible.*)
  addHyp (outgoing_del_contra n n' d v i w H2). inversion H1.
  (*So we conclude that delivered v r 0 i n for some r*)
  decompose [ex] H2. rename x0 into l. rename x into r. exists r.
  exists l.
  (*and then by the delay constructor of delivered we have our goal
  delivered v r (0 + d) i n'.*)
  replace (minusTime (nonneg (time (delToTime (t +dt+ d))))
  (nonneg (time msgLatency)) (Rlt_le (nonneg (time msgLatency))
  (nonneg (time (delToTime (t +dt+ d)))) q)) with
  (delToTime (zeroTime +dt+ d)).
  apply deliveredDel. assumption. apply timeEqR. simpl. rewrite H0. ring.
  (*Note that there are no constraints on the radius here. This agrees with the rules for
  message delivery as per the operational semantics of the network calculus, in which an
  arbitrary radius may be chosen for message delivery in order to model arbitrary variations
  in coverage.*)
  Qed.

(* If a message <m, l0> was sent t time units ago by some entity, then the distance
between l0 and the position of that entity is at most Smax*t.*)
Theorem sent_pos_bound (n : Network) (m : Mode) (t : Time) (i : nat)
  (l l0 : Position) (p : reachableNet n) :
  sent [baseMode m, basePosition l0] t i n p -> inPosNet l i n ->
  dist2d l l0 <= speedMax*t.
  (**Proof: By induction on the proof of sent.*)
  intros. generalize dependent l. induction H; intros.
  rename H3 into QQ. rename H2 into H3. rename H1 into H2. rename H0 into H1.
  rename QQ into H0. swapRename l l1.
  (*The base case would give us that the network n is reachable. From this we could
  deduce from an important general result (...reachableProt_triple...) that the software
  component of the entity i is P1 | P2 | P3.*)
  addHyp (reachable_net_prot n i q l1 h k p H). apply reachableProt_triple in H4.
  simpl in H4. invertClear H4. symmetry in H8.
  (*We could then show via another general result [salvaged?] that one of the sub-components
  must have been responsible for the output of v on the outProc channel.*)
  rewrite H8 in H2.
  assert (inPosNet l i n) as Q. erewrite inPos_pres_disc. apply H0. apply w.
  link_partripdiscex_tac2 p1' p2' p3'. link_partripout_tac Y.
  (*Using (...listener_outProc_out_not ...) we eliminate the listener case.*)
  Focus 3. lets LO : listener_outProc_out_not H7 Y. false.
  (*Now, for the broadcast case, we can infer further information with (bc_outProc_out)*)
  lets BO : bc_outProc_out Y H5.
  (*We then show by (bcReady_pos) that the position output is equal to the position of the sender.*)
  remember ([|q, l1, h, k|]) as e. assert (reachableEnt e). eapply reachable_net_ent.
  apply p. apply H. assert (bcReadyStateEnt m l0 e). rewrite Heqe. constructor.
  rewrite H8. constructor. apply BO. lets BP : bcReady_pos H4 H9.
  (*Then the goal is reduced to: |l - l| <= Smax*0 == 0 <= 0... which is trivial.*)
  eapply inPos_ent_net in BP. assert (l0 = l). eapply inPos_unique. apply BP.
  apply Q. rewrite H10. rewrite dist2D_refl. simpl. rewrite Rmult_0_r. apply Rle_refl.
  assumption.
  (*We use an analogous argument for the overlap case using (ovlp_outProc_out)*)
  lets OO : ovlp_outProc_out Y H6. decompEx2 OO u r OO'.
  remember ([|q, l1, h, k|]) as e. assert (reachableEnt e). eapply reachable_net_ent.
  apply p. apply H. assert (ovReadyStateEnt m u l0 e).
  rewrite Heqe. constructor. rewrite H8. constructor. apply OO'.
  lets OP : ovReady_pos H4 H9. eapply inPos_ent_net in OP.
  assert (l0 = l). eapply inPos_unique. apply OP. apply Q. rewrite H10.
  rewrite dist2D_refl. simpl. rewrite Rmult_0_r. apply Rle_refl. assumption.
  (*The inductive cases follow immediately from the definition of sent and the semantics.*)
  (*Either a discrete action happens, in which case both t and the position of entity i don't change,
  and so the goal carries over directly from the previous case.*)
  assert (inPosNet l i n) as Q. erewrite inPos_pres_disc. apply H0. apply w.
  apply IHsent. assumption.
  (*Alternatively, a delay happens, in which case the new position l' of entity i differs from its
  old position by at most Smax*d [salvage].*)
  addHyp (inPos_del_bound_bkwd n n' d l i H0 w). invertClear H1. rename x into l1.
  invertClear H2. apply IHsent in H1. clear IHsent. rewrite distSymmetric in H3.
  (*And so by the (triangle inequality) the difference between l' and the sent position l0
  is at most Smax*t + Smax*d = Smax*(t + d), which is exactly the goal because the time
  parameter of sent for the current state is (t + d).*)
  addHyp (dist_tri_ineq l l1 l0). eapply Rle_trans. apply H2. simpl. rewrite Rmult_plus_distr_l.
  rewrite Rplus_comm. simpl in H1, H3. apply Rplus_le_compat; assumption. Qed.

(* If an entity is nextSince m for t time units and t is greater than the message latency,
then for some l0 it has delivered a message <m, l0> to some r at t - mL time units ago,
and the l0 in the message differs from the current position by at most Smax*t.*)
Theorem fst_delivered (n : Network) (m : Mode) (t : Time) (i : nat)
  (l : Position) (p : reachableNet n) :
  nextSince m t i n p -> inPosNet l i n -> forall q : msgLatency < t,
  exists l0 l1 r,
  delivered ([-[baseMode m, basePosition l0], l1, r-])
  (minusTime t msgLatency (Rlt_le msgLatency t q)) i n p /\
  dist2d l l0 <= speedMax*t.
  (*Proof: We call on (fst_sent) to achieve sent <m, l0> r t i n p.*)
  introz U. lets FS : fst_sent U. invertClearAs2 FS l0 SEN.
  (*Now we use (sent_pos_bound) to get that |l - l0| <= Smax*t.*)
  lets SPB : sent_pos_bound SEN U0.
  (*Now we use sent_delivered to show that the sent message was delivered.*)
  lets SD : sent_delivered SEN U1. ex_flat.
  (*Now we fill in the existentials.*)
  exists l0 x0 x.
  (*The rest follows from assumptions.*)
  split; assumption. Qed.


(* These auxiliary definitions and lemmas are used in the semantics of
the abstract and quasi-abstract machines. *)

Require Import List.
Require Import Utils.

Require Import Lattices.
Require Import Instr Memory.

Set Implicit Arguments.

Local Open Scope Z_scope.

Inductive StkElmt {T S} :=
| AData : Atom T S -> StkElmt
| ARet : PcAtom T -> bool -> StkElmt.
Arguments StkElmt T S :clear implicits.
(* CH: not sure which variant is better, but in the Haskell version
       the bool in ARet is labeled by the same label as the int *)

Record AS {T S}  := AState {
  amem : memory T S;
  aimem : list Instr;
  astk : list (StkElmt T S);
  apc : PcAtom T
}.
Arguments AS T S :clear implicits.

(* DD -> DP: is PcAtom supposed to restrict the kind of output values?
             at some point, I guess the code is going to be put in memory too, at
             which point PcAtom will be also a pointer. Change it to ZAtom?
*)
Inductive Event {T: Type} :=
| EInt : PcAtom T -> @Event T.
Arguments Event T :clear implicits.

Hint Resolve flows_refl flows_join_right  flows_join_left : core.

(* Same for both the abstract and quasi-abstract machines *)
Definition abstract_init_data T :=
  (list Instr * list (PcAtom T) * T)%type.

Section ARuleMachine.

Context {T: Type}
        {Latt: JoinSemiLattice T}
        {S: Type}.

Inductive pop_to_return : list (StkElmt T S) -> list (StkElmt T S) -> Prop :=
| sptr_done: forall a b s,
    pop_to_return ((ARet a b)::s) ((ARet a b)::s)
| sptr_pop: forall a s s',
    pop_to_return s s' ->
    pop_to_return ((AData a)::s) s'.

Lemma pop_to_return_ret : forall s1 s2,
  pop_to_return s1 s2 ->
  exists a b s, s2 = (ARet a b)::s.
Proof.
  induction 1; intros; simpl; eauto.
Qed.

Lemma pop_to_return_spec : forall s1 s2,
  pop_to_return s1 s2 ->
  exists dstk, exists stk a b,
    s1 = dstk++(ARet a b)::stk
    /\ (forall e, In e dstk -> exists a, e = AData a).
Proof.
  induction 1; intros; simpl in *.
  exists nil ; exists s ; exists a ; exists b.
  simpl ; split ; eauto.
  intuition.

  destruct IHpop_to_return as [dstk [stk [a0 [b0 [Hs Hdstk]]]]].
  subst.
  exists ((AData a)::dstk).
  exists stk ; eauto.
  exists a0 ; exists b0 ; split ; eauto.
  intros. inv H0.
  eauto.
  eapply Hdstk; auto.
 Qed.

Lemma pop_to_return_spec2: forall  s1 s2 b1 b2 a1 a2 dstk,
 pop_to_return (dstk ++ ARet a1 b1 :: s2)
               (ARet a2 b2 :: s1) ->
 (forall e : StkElmt T S, In e dstk -> exists a : Atom T S, e = AData a) ->
 @ARet T S a1 b1 =  @ARet T S a2 b2.
Proof.
  induction dstk; intros.
  inv H. auto.
  simpl in *.
  inv H. destruct (H0 (ARet a2 b2)). intuition. inv H.
  eapply IHdstk; eauto.
Qed.

Lemma pop_to_return_spec3: forall s1 s2 b1 b2 a1 a2 dstk,
 pop_to_return (dstk ++ ARet a1 b1 :: s2)
               (ARet a2 b2 :: s1) ->
 (forall e, In e dstk -> exists a : Atom T S, e = AData a) ->
 s1 = s2 .
Proof.
  induction dstk; intros.
  inv H. auto.
  simpl in *.
  inv H. destruct (H0 (ARet a2 b2)). intuition. inv H.
  eapply IHdstk; eauto.
Qed.

End ARuleMachine.

Record ASysCall T : Type := {
  asi_arity : nat;
  asi_sem : forall S, list (Atom T S) -> option (Atom T S)
}.

Definition ASysTable T : Type := ident -> option (ASysCall T).