(*
 * SPDX-License-Identifier: MIT
 *
 *)
From Coq Require Import
     Classical
     Morphisms
     JMeq
     List
     Lia.

From SPICY Require Import
     MyPrelude
     Automation
     Maps
     Keys
     Messages
     MessageEq
     Tactics
     Simulation
     RealWorld
     AdversaryUniverse
     AdversarySafety
     SafetyAutomation
     SyntacticallySafe

     Theory.CipherTheory
     Theory.InvariantsTheory
     Theory.KeysTheory
     Theory.MessagesTheory
     Theory.MessageEqTheory
     Theory.UsersTheory

     ModelCheck.ModelCheck
     ModelCheck.Commutation
     ModelCheck.LabelsAlign
     ModelCheck.NoResends
     ModelCheck.RealWorldStepLemmas
     ModelCheck.SafeProtocol
.

From Frap Require Import
     Invariant.

From Frap Require
     Sets.

From SPICY Require
     IdealWorld.

Import SafetyAutomation.

(* For later import of set notations inside sections *)
Module Foo <: Sets.EMPTY.
End Foo.
Module SN := Sets.SetNotations(Foo).

Set Implicit Arguments.

Section NextSteps.

  Inductive nextStepSS {A B} (u_id : user_id) (userData : user_data A)
    : universe A B (* -> universe A B *) -> Prop :=

  | NextSilent : forall U U',
      U.(users) $? u_id = Some userData
      -> indexedRealStep u_id Silent U U'
      -> (forall uid' U', uid' > u_id -> ~ indexedRealStep uid' Silent U U')
      -> nextStepSS u_id userData U

  | NoSilents : forall U U' a,
      U.(users) $? u_id = Some userData

      (* No one can silently step *)
      -> (forall uid' U', ~ indexedRealStep uid' Silent U U')

      -> indexedRealStep u_id (Action a) U U'
      -> nextStepSS u_id userData U.

  Inductive stepSS (t__hon t__adv : type) :
      @ModelState t__hon t__adv
    -> @ModelState t__hon t__adv
    -> Prop :=

  | StepNextSS : forall ru ru' iu iu' u_id ud st st' v v',
      nextStepSS u_id ud ru
      -> st = (ru,iu,v)
      -> st' = (ru',iu',v')
      -> indexedModelStep u_id st st'
      -> stepSS st st'.

End NextSteps.

(* Load the set notations *)
Import SN.

Definition TrSS {t__hon t__adv} (ru0 : RealWorld.universe t__hon t__adv) (iu0 : IdealWorld.universe t__hon) :=
  {| Initial := {(ru0, iu0, true)};
     Step    := @stepSS t__hon t__adv |}.

#[export] Hint Resolve adversary_remains_lame_step : core.
#[export] Hint Constructors stepSS nextStepSS : core.

(* #[export] Hint Resolve indexedIdealSteps_ideal_steps : core. *)
#[export] Hint Constructors indexedModelStep indexedIdealStep indexedRealStep : core.
#[export] Hint Resolve action_matches_other_user_silent_step_inv : core.

Lemma step_then_step' :
  forall {A B C} suid lbl bd bd',

    step_user lbl suid bd bd'
    -> forall cs cs' (usrs usrs': honest_users A) (adv adv' : user_data B) gks gks'
        (cmd cmd' : user_cmd C) uid1 ks ks' qmsgs qmsgs' mycs mycs'
        froms froms' sents sents' cur_n cur_n' cmdc,

      bd = (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, cmd)
      -> bd' = (usrs', adv', cs', gks', ks', qmsgs', mycs', froms', sents', cur_n', cmd')
      -> suid = Some uid1
      -> usrs $? uid1 = Some {| key_heap := ks;
                               protocol := cmdc;
                               msg_heap := qmsgs;
                               c_heap   := mycs;
                               from_nons := froms;
                               sent_nons := sents;
                               cur_nonce := cur_n |}
      -> message_queues_ok cs usrs gks
      -> user_cipher_queues_ok cs (findUserKeys usrs) usrs
      -> forall usrs'' (adv'' : user_data B) cs'' gks'' ms,
          usrs'' $? uid1 = Some {| key_heap := ks;
                                   protocol := cmdc;
                                   msg_heap := qmsgs ++ ms;
                                   c_heap   := mycs;
                                   from_nons := froms;
                                   sent_nons := sents;
                                   cur_nonce := cur_n |}
          -> (forall uid u, usrs $? uid = Some u -> exists u', usrs'' $? uid = Some u')
          -> (forall cid c, cs $? cid = Some c -> cs'' $? cid = Some c)
          -> (forall cid c, cs'' $? cid = Some c -> cs $? cid = Some c \/ cs $? cid = None)
          -> (forall kid k, gks $? kid = Some k -> gks'' $? kid = Some k)
          -> exists bd'',
              step_user lbl suid
                        (usrs'', adv'', cs'', gks'', ks, qmsgs ++ ms, mycs, froms, sents, cur_n, cmd)
                        bd''.
Proof.
  induction 1; inversion 1; inversion 1
  ; intros
  ; subst
  ; try solve [ eexists; econstructor; eauto ]
  ; clean_context.

  - eapply IHstep_user in H26; eauto.
    split_ex.
    dt x; eexists; econstructor; eauto.

  - rewrite <- app_assoc,
            <- app_comm_cons.
    eexists; econstructor; eauto.
    invert H6;
      [ econstructor 1
      | econstructor 2
      | econstructor 3
      ]; eauto.

    rewrite Forall_forall in H7|- *
    ; intros.

    generalize (H7 _ H)
    ; intros
    ; destruct x
    ; eauto.

    unfold not
    ; intros MAP
    ; apply H0.

    msg_queue_prop.
    apply List.Forall_app in H2
    ; split_ex
    ; rewrite Forall_forall in H2
    ; apply H2 in H
    ; split_ex.

    invert MAP;
      [ econstructor 1
      | econstructor 2
      | econstructor 3
      ]
      ; eauto
      ; specialize (H8 _ eq_refl).

    apply H39 in H11; split_ors; clean_map_lookups; eauto.
    apply H39 in H11; split_ors; clean_map_lookups; eauto.

  - apply H36 in H2; split_ex; eauto.
    eexists; econstructor; eauto.
    unfold keys_mine in H0 |- *; intros.
    apply H0.
    unfold findKeysCrypto in H2 |- *.
    destruct msg; eauto.
    assert (List.In c_id mycs') by eauto.
    user_cipher_queues_prop.
    generalize (H37 _ _  H5); intros; context_map_rewrites; trivial.

  - eexists.
    eapply StepEncrypt with (c_id0 := next_key cs''); clean_map_lookups; eauto.
    eapply next_key_not_in; eauto.

  - eexists.
    eapply StepSign with (c_id0 := next_key cs''); clean_map_lookups; eauto.
    eapply next_key_not_in; eauto.

  - eexists.
    eapply StepGenerateKey with (k_id0 := next_key gks''); clean_map_lookups; eauto.
    eapply next_key_not_in; eauto.
    Unshelve.
    auto.
Qed.

Lemma step_then_silent_step :
  forall {A B C} suid lbl bd bd',

    step_user lbl suid bd bd'
    -> forall cs cs' (usrs usrs': honest_users A) (adv adv' : user_data B) gks gks'
        (cmd cmd' : user_cmd C) uid1 ks ks' qmsgs qmsgs' mycs mycs'
        froms froms' sents sents' cur_n cur_n' cmdc,

      bd = (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, cmd)
      -> bd' = (usrs', adv', cs', gks', ks', qmsgs', mycs', froms', sents', cur_n', cmd')
      -> suid = Some uid1
      -> usrs $? uid1 = Some {| key_heap := ks;
                               protocol := cmdc;
                               msg_heap := qmsgs;
                               c_heap   := mycs;
                               from_nons := froms;
                               sent_nons := sents;
                               cur_nonce := cur_n |}
      (* -> forall ctx styp, syntactically_safe uid1 (compute_ids usrs) ctx cmd styp *)
      (* -> typingcontext_sound ctx usrs cs uid1 *)
      -> message_queues_ok cs usrs gks
      -> user_cipher_queues_ok cs (findUserKeys usrs) usrs
      -> forall uid2 bd2 bd2',
          step_user Silent (Some uid2) bd2 bd2'

          -> forall cmd2 ks2 qmsgs2 mycs2 froms2 sents2 cur_n2 usrs'' cmdc' ud2,

            uid1 <> uid2
            -> usrs $? uid2 = Some ud2
            -> bd2 = build_data_step (mkUniverse usrs adv cs gks) ud2
            -> usrs' $? uid2 = Some {| key_heap := ks2;
                                      protocol := cmd2;
                                      msg_heap := qmsgs2;
                                      c_heap   := mycs2;
                                      from_nons := froms2;
                                      sent_nons := sents2;
                                      cur_nonce := cur_n2 |}
            -> usrs'' = usrs' $+ (uid1, {| key_heap := ks';
                                          protocol := cmdc';
                                          msg_heap := qmsgs';
                                          c_heap   := mycs';
                                          from_nons := froms';
                                          sent_nons := sents';
                                          cur_nonce := cur_n' |})
            -> exists bd2'',
                step_user Silent (Some uid2)
                          (usrs'', adv', cs', gks', ks2, qmsgs2, mycs2, froms2, sents2, cur_n2, cmd2)
                          bd2''
.
Proof.

  Ltac ss :=
    clean_map_lookups
    ; unfold build_data_step in *
    ; simpl in *
    ; eauto
    ; match goal with
      | [ H : step_user Silent (Some ?uid) _ ?bd
          |- exists _, step_user _ (Some ?uid) (?us,_,?cs,?gks,_,_,_,_,_,_,_) _ ] =>
        dt bd
        ; eapply step_then_step' with (ms := []) (usrs'' := us) (cs'' := cs) (gks'' := gks) in H
      end
    ; eauto
    ; try rewrite app_nil_r in *
    ; eauto
    ; try
        match goal with
        | [ |- forall _ _, ?usrs $? _ = Some _ -> exists _, ?usrs $+ (?uid,_) $? _ = Some _ ] =>
          let UID := fresh "UID"
          in intros UID *; destruct (UID ==n uid); subst; eexists; clean_map_lookups; eauto
        end.

  induction 1; inversion 1; inversion 1; intros; subst
  ; try solve [ ss ]; clean_context.

  - destruct (rec_u_id ==n uid2); subst; clean_map_lookups.
    + destruct ud2
      ; clean_map_lookups
      ; unfold build_data_step in *
      ; simpl in *
      ; eauto
      ; match goal with
        | [ H : step_user Silent (Some ?uid) _ ?bd
            |- exists _, step_user _ (Some ?uid) (?us,_,?cs,?gks,_,_,_,_,_,_,_) _ ] =>
          dt bd
          ; eapply step_then_step' with (ms := [existT _ _ msg]) (usrs'' := us) (cs'' := cs) (gks'' := gks) in H
        end
      ; eauto
      ; try rewrite app_nil_r in *
      ; eauto
      ; try
          match goal with
          | [ |- forall _ _, ?usrs $? _ = Some _ -> exists _, ?usrs $+ (?uid,_) $? _ = Some _ ] =>
            let UID := fresh "UID"
            in intros UID *; destruct (UID ==n uid); subst; eexists; clean_map_lookups; eauto
          end.

      intros.
      destruct (uid ==n uid1); destruct (uid ==n uid2); subst; eexists; clean_map_lookups; eauto.

    + ss.
      intros.
      destruct (uid ==n uid1); destruct (uid ==n rec_u_id); subst; eexists; clean_map_lookups; eauto.

  - unfold build_data_step in *
    ; clean_map_lookups
    ; simpl in *.

    match goal with
    | [ H : step_user Silent (Some ?uid) _ ?bd
        |- exists _, step_user _ (Some ?uid) (?us,_,?cs,?gks,_,_,_,_,_,_,_) _ ] =>
      dt bd
      ; eapply step_then_step' with (ms := []) (usrs'' := us) (cs'' := cs) (gks'' := gks) in H
    end
    ; try rewrite app_nil_r in *
    ; split_ex; eauto.

    intros.
    destruct (uid ==n uid1); destruct (uid ==n uid2); subst; eexists; clean_map_lookups; eauto.

    intros.
    destruct (c_id ==n cid); subst; clean_map_lookups; eauto.

  - unfold build_data_step in *
    ; clean_map_lookups
    ; simpl in *.

    match goal with
    | [ H : step_user Silent (Some ?uid) _ ?bd
        |- exists _, step_user _ (Some ?uid) (?us,_,?cs,?gks,_,_,_,_,_,_,_) _ ] =>
      dt bd
      ; eapply step_then_step' with (ms := []) (usrs'' := us) (cs'' := cs) (gks'' := gks) in H
    end
    ; try rewrite app_nil_r in *
    ; split_ex; eauto.

    intros.
    destruct (uid ==n uid1); destruct (uid ==n uid2); subst; eexists; clean_map_lookups; eauto.

    intros.
    destruct (c_id ==n cid); subst; clean_map_lookups; eauto.

    Unshelve.
    all: eauto.
Qed.

Lemma step_limited_change_other_user_qmsgs :
  forall A B cs cs' (usrs usrs': honest_users A) (adv adv' : user_data B) gks gks'
    (cmd cmd' : user_cmd (Base A)) ks ks' qmsgs qmsgs' mycs mycs'
    froms froms' sents sents' cur_n cur_n' uid uid' lbl
    ks1 cmd1 qmsgs1 mycs1 froms1 sents1 cur_n1,

    usrs $? uid = Some (mkUserData ks1 cmd1 qmsgs1 mycs1 froms1 sents1 cur_n1)
    -> uid <> uid'
    -> usrs $? uid' = Some (mkUserData ks cmd qmsgs mycs froms sents cur_n)
    -> step_user lbl (Some uid')
                (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, cmd)
                (usrs', adv', cs', gks', ks', qmsgs', mycs', froms', sents', cur_n', cmd')
    -> exists qmsgs1',
        (usrs' $+ (uid', mkUserData ks' cmd' qmsgs' mycs' froms' sents' cur_n')) $? uid
        = Some (mkUserData ks1 cmd1 qmsgs1' mycs1 froms1 sents1 cur_n1)
        /\ (qmsgs1' = qmsgs1 \/ exists m, qmsgs1' = qmsgs1 ++ [m])
.
Proof.
  intros.
  specialize (user_step_adds_no_users H2 eq_refl eq_refl); intros.
  generalize H2; intros STEP.
  eapply step_limited_change_other_user with (u_id2 := uid) in STEP; eauto; split_ex.

  split_ors; split_ex; eauto.
Qed.

Definition useless_summary : summary :=
  {| sending_to := Sets.scomp (fun (n : nat) => True) |}.

Lemma useless_summary_summarizes :
  forall t cmd,
    @summarize t cmd useless_summary.
Proof.
  induction cmd; econstructor; eauto; simpl.
  unfold Sets.scomp, Sets.In; simpl; trivial.
Qed.

Lemma silent_step_na_commuting :
  forall {A B C} suid lbl bd bd',

    step_user lbl suid bd bd'

    -> forall cs cs' (usrs usrs': honest_users A) (adv adv' : user_data B) gks gks'
        (cmd cmd' : user_cmd C) ks ks' qmsgs qmsgs' mycs mycs'
        froms froms' sents sents' cur_n cur_n',

      bd = (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, cmd)
      -> bd' = (usrs', adv', cs', gks', ks', qmsgs', mycs', froms', sents', cur_n', cmd')
      -> lbl = Silent
      -> forall s,
          exists t cmd__n,
            @nextAction _ t cmd cmd__n
            /\ commutes cmd__n s.
Proof.
  #[export] Hint Constructors nextAction : core.
  induction 1; inversion 1; inversion 1; intros; subst; simpl; try discriminate
  ; try solve [ (do 2 eexists); split; eauto; simpl; trivial ].

  specialize (IHstep_user _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ eq_refl eq_refl eq_refl s)
  ; split_ex
  ; (do 2 eexists)
  ; split
  ; [ econstructor |]
  ; eauto.
Qed.

Lemma step_didnt_appear :
  forall {A B C} suid lbl bd bd',

    step_user lbl suid bd bd'
    -> forall cs cs' (usrs usrs': honest_users A) (adv adv' : user_data B) gks gks'
        (cmd cmd' : user_cmd C) uid1 ks ks' qmsgs qmsgs' mycs mycs' ms
        froms froms' sents sents' cur_n cur_n' cmdc,

      bd = (usrs, adv, cs, gks, ks, qmsgs ++ ms, mycs, froms, sents, cur_n, cmd)
      -> bd' = (usrs', adv', cs', gks', ks', qmsgs', mycs', froms', sents', cur_n', cmd')
      -> suid = Some uid1
      -> lbl = Silent
      -> usrs $? uid1 = Some {| key_heap := ks;
                               protocol := cmdc;
                               msg_heap := qmsgs ++ ms;
                               c_heap   := mycs;
                               from_nons := froms;
                               sent_nons := sents;
                               cur_nonce := cur_n |}
      -> forall usrs'' (adv'' : user_data B) cs'' gks'',
          usrs'' $? uid1 = Some {| key_heap := ks;
                                   protocol := cmdc;
                                   msg_heap := qmsgs;
                                   c_heap   := mycs;
                                   from_nons := froms;
                                   sent_nons := sents;
                                   cur_nonce := cur_n |}
          -> forall ctx styp, syntactically_safe uid1 (compute_ids usrs'') ctx cmd styp
          -> typingcontext_sound ctx usrs'' cs'' uid1
          -> keys_and_permissions_good gks'' usrs'' adv''.(key_heap)
          -> user_cipher_queues_ok cs'' (findUserKeys usrs'') usrs''
          -> (forall uid u, usrs'' $? uid = Some u -> exists u', usrs $? uid = Some u')
          -> (forall cid c, cs'' $? cid = Some c -> cs $? cid = Some c)
          -> (forall cid c, cs $? cid = Some c -> cs'' $? cid = Some c \/ cs'' $? cid = None)
          -> (forall kid k, gks'' $? kid = Some k -> gks $? kid = Some k)
          -> exists bd'',
              step_user Silent suid
                        (usrs'', adv'', cs'', gks'', ks, qmsgs, mycs, froms, sents, cur_n, cmd)
                        bd''.
Proof.
  induction 1; inversion 1; inversion 1
  ; intros
  ; subst
  ; try discriminate
  ; try solve [ eexists; econstructor; eauto ]
  ; clean_context.

  - invert H28.
    eapply IHstep_user in H27; eauto.
    split_ex.
    dt x; eexists; econstructor; eauto.

  - unfold typingcontext_sound in *
    ; split_ex
    ; invert H38
    ; process_ctx.
    keys_and_permissions_prop.

    generalize (H13 _ _ H9)
    ; generalize (H13 _ _ H10)
    ; intros; split_ex.

    generalize (H45 _ _ H19)
    ; generalize (H45 _ _ H20)
    ; intros
    ; clean_map_lookups.

    eapply StepEncrypt with (c_id0 := next_key cs''); clean_map_lookups; eauto.
    eapply next_key_not_in; eauto.

  - eexists.
    assert (List.In c_id mycs'0) by eauto.
    user_cipher_queues_prop.
    eapply H42 in H; split_ors; clean_map_lookups; eauto.
    keys_and_permissions_prop.

    generalize (H11 _ _ H2)
    ; generalize (H11 _ _ H3)
    ; intros
    ; clean_map_lookups
    ; clear H11.

    generalize (H43 _ _ H12)
    ; generalize (H43 _ _ H13)
    ; intros
    ; clean_map_lookups
    ; clear H43.

    econstructor; eauto.

  - keys_and_permissions_prop.

    generalize (H8 _ _ H0)
    ; intros
    ; clean_map_lookups.

    generalize (H43 _ _ H9)
    ; intros
    ; clean_map_lookups.

    eexists.
    eapply StepSign with (c_id0 := next_key cs''); clean_map_lookups; eauto.
    eapply next_key_not_in; eauto.

  - keys_and_permissions_prop.

    generalize (H7 _ _ H0)
    ; intros
    ; clean_map_lookups.

    generalize (H38 _ _ H8)
    ; intros
    ; clean_map_lookups.

    assert (List.In c_id mycs') by eauto.
    user_cipher_queues_prop.
    eapply H37 in H1; split_ors; clean_map_lookups; eauto.

    eexists.
    econstructor; eauto.

  - eexists.

    eapply StepGenerateKey with (k_id0 := next_key gks''); clean_map_lookups; eauto.
    eapply next_key_not_in; eauto.

    Unshelve.
    auto.
Qed.

Lemma step_then_silent_step_inv :
  forall {A B C} suid lbl bd bd',

    step_user lbl suid bd bd'
    -> forall cs cs' (usrs usrs': honest_users A) (adv adv' : user_data B) gks gks'
        (cmd cmd' : user_cmd C) uid1 ks ks' qmsgs qmsgs' mycs mycs'
        froms froms' sents sents' cur_n cur_n' cmdc,

      bd = (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, cmd)
      -> bd' = (usrs', adv', cs', gks', ks', qmsgs', mycs', froms', sents', cur_n', cmd')
      -> suid = Some uid1
      -> usrs $? uid1 = Some {| key_heap := ks;
                               protocol := cmdc;
                               msg_heap := qmsgs;
                               c_heap   := mycs;
                               from_nons := froms;
                               sent_nons := sents;
                               cur_nonce := cur_n |}

      -> forall uid2 bd2 bd2' cmd2 ks2 qmsgs2 mycs2 froms2 sents2 cur_n2 usrs'' cmdc' ud2,

          step_user Silent (Some uid2)
                    (usrs'', adv', cs', gks', ks2, qmsgs2, mycs2, froms2, sents2, cur_n2, cmd2)
                    bd2'
          -> uid1 <> uid2
          -> usrs $? uid2 = Some ud2
          -> bd2 = build_data_step (mkUniverse usrs adv cs gks) ud2
          -> usrs' $? uid2 = Some {| key_heap := ks2;
                                    protocol := cmd2;
                                    msg_heap := qmsgs2;
                                    c_heap   := mycs2;
                                    from_nons := froms2;
                                    sent_nons := sents2;
                                    cur_nonce := cur_n2 |}
          -> usrs'' = usrs' $+ (uid1, {| key_heap := ks';
                                        protocol := cmdc';
                                        msg_heap := qmsgs';
                                        c_heap   := mycs';
                                        from_nons := froms';
                                        sent_nons := sents';
                                        cur_nonce := cur_n' |})
          -> forall ctx styp, syntactically_safe uid2 (compute_ids usrs) ctx cmd2 styp
                        -> typingcontext_sound ctx usrs cs uid2
                        -> keys_and_permissions_good gks usrs adv.(key_heap)
                        -> user_cipher_queues_ok cs (findUserKeys usrs) usrs
                        -> exists bd2'',
                            step_user Silent (Some uid2) bd2 bd2''
.
Proof.
  induction 1; inversion 1; inversion 1; intros; subst; clean_context
  ; autorewrite with find_user_keys in *
  ; try solve [
          dt bd2'; clean_map_lookups
          ; eapply step_didnt_appear with (ms := [])
          ; try rewrite app_nil_r
          ; simpl; eauto
          ; intros; destruct (uid1 ==n uid); subst; clean_map_lookups; eauto ].

  - eapply IHstep_user in H30; eauto.
  - simpl in *.
    destruct (rec_u_id ==n uid2); subst; clean_map_lookups; eauto.

    + dt bd2'; destruct ud2; clean_map_lookups.
      eapply step_didnt_appear with (ms := [existT crypto t0 msg]); simpl in *; eauto.

      intros
      ; destruct (uid1 ==n uid)
      ; destruct (uid2 ==n uid)
      ; subst; clean_map_lookups; eauto.

    + dt bd2'; clean_map_lookups
      ; eapply step_didnt_appear with (ms := [])
      ; try rewrite app_nil_r
      ; simpl in *
      ; eauto.

      intros
      ; destruct (rec_u_id ==n uid)
      ; destruct (uid1 ==n uid)
      ; subst; clean_map_lookups; eauto.

  - dt bd2'; clean_map_lookups
    ; eapply step_didnt_appear with (ms := [])
    ; try rewrite app_nil_r
    ; simpl; eauto.

    intros; destruct (uid1 ==n uid); subst; clean_map_lookups; eauto.
    intros; destruct (c_id ==n cid); subst; clean_map_lookups; eauto.

  - dt bd2'; clean_map_lookups
    ; eapply step_didnt_appear with (ms := [])
    ; try rewrite app_nil_r
    ; simpl; eauto.

    intros; destruct (uid1 ==n uid); subst; clean_map_lookups; eauto.
    intros; destruct (c_id ==n cid); subst; clean_map_lookups; eauto.
Qed.

Lemma silent_step_commutes_noblock :
  forall t__hon t__adv (usrs usrs' : honest_users t__hon) (adv adv' : user_data t__adv) cs cs' gks gks'
    ks2 ks2' qmsgs2 qmsgs2' mycs2 mycs2' froms2 froms2' sents2 sents2' cur_n2 cur_n2' cmd2 cmd2' uid2,

    usrs $? uid2 = Some (mkUserData ks2 cmd2 qmsgs2 mycs2 froms2 sents2 cur_n2)
    -> step_user Silent (Some uid2)
                (usrs, adv, cs, gks, ks2, qmsgs2, mycs2, froms2, sents2, cur_n2, cmd2)
                (usrs', adv', cs', gks', ks2', qmsgs2', mycs2', froms2', sents2', cur_n2', cmd2')
    -> forall uid1, uid1 <> uid2
    -> forall (usrs1' : honest_users t__hon) (adv1' : user_data t__adv) cs1' gks1'
        ks1 ks1' qmsgs1 qmsgs1' mycs1 mycs1' froms1 froms1' sents1 sents1' cur_n1 cur_n1' cmd1 cmd1' lbl1,

        usrs $? uid1 = Some (mkUserData ks1 cmd1 qmsgs1 mycs1 froms1 sents1 cur_n1)
        -> step_user lbl1 (Some uid1)
                  (usrs, adv, cs, gks, ks1, qmsgs1, mycs1, froms1, sents1, cur_n1, cmd1)
                  (usrs1', adv1', cs1', gks1', ks1', qmsgs1', mycs1', froms1', sents1', cur_n1', cmd1')
        -> forall ks2'' qmsgs2'' mycs2'' froms2'' sents2'' cur_n2'',
          usrs1' $? uid2 = Some (mkUserData ks2'' cmd2 qmsgs2'' mycs2'' froms2'' sents2'' cur_n2'')
        -> exists usrs2' adv2' cs2' gks2' ks2''' qmsgs2''' mycs2''' froms2''' sents2''' cur_n2''' cmd2'',
          step_user Silent (Some uid2)
                    (usrs1' $+ (uid1, mkUserData ks1' cmd1' qmsgs1' mycs1' froms1' sents1' cur_n1'),
                     adv1', cs1', gks1', ks2'', qmsgs2'', mycs2'', froms2'', sents2'', cur_n2'', cmd2)
                    (usrs2', adv2', cs2', gks2', ks2''', qmsgs2''', mycs2''', froms2''', sents2''', cur_n2''', cmd2'')
.
Proof.
  intros.

  pose proof (useless_summary_summarizes cmd1).
  generalize H0; intros SS
  ; eapply silent_step_na_commuting with (s := useless_summary) in H0; eauto
  ; split_ex.

  generalize SS; intros STEP
  ; eapply commutes_noblock with (uid1 := uid1) (uid2 := uid2) (summaries := $0 $+ (uid1,useless_summary)) in SS
  ; eauto.
Qed.

Lemma translate_trace_commute :
  forall t__hon t__adv i st st' b,
    @stepsi t__hon t__adv (1 + i) st st'
    -> lameAdv b (fst (fst st)).(adversary)
    -> syntactically_safe_U (fst (fst st))
    -> goodness_predicates (fst (fst st))
    -> (forall st'', ~ step st' st'')
    -> forall uid ud, (fst (fst st)).(users) $? uid = Some ud
    (* -> (forall uid' U', uid' > uid -> ~ indexedRealStep uid' Silent (fst (fst st)) U') *)
    -> forall bd, step_user Silent (Some uid) (build_data_step (fst (fst st)) ud) bd
    -> exists st0 st0',
          indexedModelStep uid st st0
        /\ stepsi i st0 st0'
        /\ fst st0' = fst st'
        /\ ( snd st0' = snd st' \/ (snd st0' = false /\ snd st' = true) )
.
Proof.
  induct 1; intros; eauto.
  invert H0.

  - clear IHstepsi.
    invert H; simpl in *;
      repeat
        match goal with
        | [ H : ?x = ?x |- _ ] => clear H
        | [ H : step_universe _ _ _ _ |- _ ] => invert H; dismiss_adv
        | [ H : indexedRealStep _ _ _ _ |- _ ] => invert H
        | [ H : Silent = mkULbl ?lbl _ |- _ ] => unfold mkULbl in H; destruct lbl; try discriminate
        end.

    + destruct (uid ==n u_id); subst; clean_map_lookups.

      (* equal *)
      (do 2 eexists); repeat simple apply conj; simpl; try econstructor; eauto 8.

      (* not equal *)

      unfold build_data_step in *
      ; destruct userData, ud
      ; simpl in *
      ; generalize H7; intros STEP
      ; eapply step_limited_change_other_user with (u_id1 := u_id) (u_id2 := uid) in H7
      ; eauto
      ; split_ex
      ; simpl in *.

      exfalso.
      unfold goodness_predicates in *; split_ex.

      split_ors; split_ex; clean_map_lookups
      ; eapply step_then_silent_step with (uid1 := u_id) (uid2 := uid) in STEP
      ; eauto
      ; split_ex.

      dt x
      ; eapply H4
      ; econstructor 1; eauto
      ; eapply StepUser with (u_id0 := uid)
      ; unfold build_data_step, buildUniverse; simpl
      ; eauto.

      dt x0
      ; eapply H4
      ; econstructor 1; eauto
      ; eapply StepUser with (u_id0 := uid)
      ; unfold build_data_step, buildUniverse; simpl
      ; eauto.

    + destruct (uid ==n uid0); subst; clean_map_lookups.

      (* equal *)
      eapply user_step_label_deterministic in H6; eauto; discriminate.

      (* not equal *)
      unfold build_data_step in *
      ; destruct userData, ud
      ; dt bd
      ; simpl in *
      ; generalize H11; intros STEP
      ; eapply step_limited_change_other_user with (u_id1 := uid0) (u_id2 := uid) in H11
      ; eauto
      ; split_ex
      ; simpl in *.

      exfalso.
      unfold goodness_predicates in *; split_ex.

      split_ors; split_ex; clean_map_lookups
      ; eapply step_then_silent_step with (uid1 := uid0) (uid2 := uid) in STEP
      ; eauto
      ; split_ex.

      dt x
      ; eapply H4
      ; econstructor 1; eauto
      ; eapply StepUser with (u_id := uid)
      ; unfold build_data_step, buildUniverse; simpl
      ; eauto.

      dt x0
      ; eapply H4
      ; econstructor 1; eauto
      ; eapply StepUser with (u_id := uid)
      ; unfold build_data_step, buildUniverse; simpl
      ; eauto.

    + destruct (uid ==n uid0); subst; clean_map_lookups.

      (* equal *)
      eapply user_step_label_deterministic in H6; eauto; discriminate.

      (* not equal *)
      unfold build_data_step in *
      ; destruct userData, ud
      ; dt bd
      ; simpl in *
      ; generalize H10; intros STEP
      ; eapply step_limited_change_other_user with (u_id1 := uid0) (u_id2 := uid) in H10
      ; eauto
      ; split_ex
      ; simpl in *.

      exfalso.
      unfold goodness_predicates in *; split_ex.

      split_ors; split_ex; clean_map_lookups
      ; eapply step_then_silent_step with (uid1 := uid0) (uid2 := uid) in STEP
      ; eauto
      ; split_ex.

      dt x
      ; eapply H4
      ; econstructor 1; eauto
      ; eapply StepUser with (u_id := uid)
      ; unfold build_data_step, buildUniverse; simpl
      ; eauto.

      dt x0
      ; eapply H4
      ; econstructor 1; eauto
      ; eapply StepUser with (u_id := uid)
      ; unfold build_data_step, buildUniverse; simpl
      ; eauto.

    + destruct (uid ==n uid0); subst; clean_map_lookups.

      (* equal *)
      eapply user_step_label_deterministic in H6; eauto; discriminate.

      (* not equal *)
      unfold build_data_step in *
      ; destruct userData, ud
      ; dt bd
      ; simpl in *
      ; generalize H10; intros STEP
      ; eapply step_limited_change_other_user with (u_id1 := uid0) (u_id2 := uid) in H10
      ; eauto
      ; split_ex
      ; simpl in *.

      exfalso.
      unfold goodness_predicates in *; split_ex.

      split_ors; split_ex; clean_map_lookups
      ; eapply step_then_silent_step with (uid1 := uid0) (uid2 := uid) in STEP
      ; eauto
      ; split_ex.

      dt x
      ; eapply H4
      ; econstructor 1; eauto
      ; eapply StepUser with (u_id := uid)
      ; unfold build_data_step, buildUniverse; simpl
      ; eauto.

      dt x0
      ; eapply H4
      ; econstructor 1; eauto
      ; eapply StepUser with (u_id := uid)
      ; unfold build_data_step, buildUniverse; simpl
      ; eauto.

  - assert (LAME: lameAdv b (adversary (fst (fst st)))) by assumption.
    eapply adversary_remains_lame_step in LAME; eauto.

    assert (SS : syntactically_safe_U (fst (fst st'))) by eauto using syntactically_safe_U_preservation_step.

    assert (UNIVS : goodness_predicates (fst (fst st'))).
    eapply goodness_preservation_step; eauto.

    specialize (IHstepsi _ _ eq_refl LAME SS UNIVS H4).
    clear LAME SS UNIVS.

    dt bd; destruct ud; simpl in *.

    invert H; simpl in *;
      repeat
      match goal with
      | [ H : step_universe _ _ _ _ |- _ ] => invert H; dismiss_adv
      | [ H : indexedRealStep _ _ _ _ |- _ ] => invert H
      | [ H : Silent = mkULbl ?lbl _ |- _ ] => unfold mkULbl in H; destruct lbl; try discriminate
      end;
      (* match goal with *)
      (* | [ H : O.max_elt _ = Some _ |- _ ] => *)
      (*   let MAX := fresh "H" *)
      (*   in generalize H; intros MAX; *)
      (*        apply NatMap.O.max_elt_MapsTo in MAX; rewrite find_mapsto_iff in MAX *)
      (* end; *)
      try rename u_id into uid0.

    + destruct (uid ==n uid0); subst; clean_map_lookups.

      (* equal *)
      (do 2 eexists); repeat simple apply conj; eauto.
      econstructor; eauto.
      econstructor; eauto.

      (* not equal *)
      (* assert (LK : users ru $? uid0 = Some userData) by assumption. *)
      (* eapply H8 in LK; eauto; split_ex.     gathers summaries *)

      destruct userData; unfold buildUniverse, build_data_step in *; simpl in *.
      (* specialize (H5 _ _ x H); split_ex. (* specializes summary *) *)

      generalize H9; intros STEP
      ; eapply step_limited_change_other_user_qmsgs with (uid := uid) (uid' := uid0) in STEP
      ; eauto; split_ex.
      rename x into msg_heap'.

      specialize (IHstepsi _ _ H0); simpl in *.

      eapply silent_step_commutes_noblock with (usrs := users ru) (usrs1' := usrs0) in H6; eauto.
      2: clean_map_lookups; eauto.
      split_ex.

      generalize H6; intros SS; eapply IHstepsi in H6; eauto.
      clear IHstepsi; split_ex; subst.

      Ltac clear_mislabeled_steps :=
        repeat
          match goal with
          | [ H : indexedRealStep _ _ _ _ |- _ ] => invert H
          | [ H1 : step_user (Action _) (Some ?uid) _ _
            , H2 : step_user Silent (Some ?uid) _ _ |- _ ] =>
            unfold build_data_step in *
            ; simpl in *
            ; clean_map_lookups
            ; simpl in *
            ; pose proof (user_step_label_deterministic _ _ _ _ _ _ _ _ _ H1 H2)
            ; discriminate
          end.

      invert H6; clear_mislabeled_steps.

      pose proof (useless_summary_summarizes protocol0).
      eapply silent_step_na_commuting with (s := useless_summary) in SS; eauto
      ; split_ex.

      eapply commutes_sound with (u_id1 := uid0) (u_id2 := uid) in H14; eauto; simpl.

      split_ex; subst.
      unfold build_data_step in H14; destruct ru.
      dt x14; dt x15; destruct x16; simpl in *.

      (do 2 eexists); repeat simple apply conj; eauto.
      econstructor 1; eauto.
      econstructor; eauto.
      econstructor 1; eauto.
      econstructor 1; eauto.

    + destruct (uid ==n uid0); subst; clean_map_lookups; clear_mislabeled_steps.

      destruct userData; unfold buildUniverse, build_data_step in *; simpl in *.

      generalize H13; intros STEP
      ; eapply step_limited_change_other_user_qmsgs with (uid := uid) (uid' := uid0) in STEP
      ; eauto; split_ex.
      rename x into msg_heap'.

      specialize (IHstepsi _ _ H0); simpl in *.

      eapply silent_step_commutes_noblock with (usrs := users ru) (usrs1' := usrs0) in H6; eauto.
      2: clean_map_lookups; eauto.
      split_ex.

      generalize H6; intros SS; eapply IHstepsi in H6; eauto.
      clear IHstepsi; split_ex; subst.

      invert H6; clear_mislabeled_steps.

      pose proof (useless_summary_summarizes protocol0).
      eapply silent_step_na_commuting with (s := useless_summary) in SS; eauto
      ; split_ex.

      eapply commutes_sound with (u_id1 := uid0) (u_id2 := uid) in H18; eauto; simpl.

      split_ex; subst.
      unfold build_data_step in H18; destruct ru.
      dt x14; dt x15; destruct x16; simpl in *.

      destruct (classic (labels_align (buildUniverse usrs2 adv2 cs2 gks2 uid
                {|
                key_heap := ks2;
                protocol := cmd2;
                msg_heap := qmsgs2;
                c_heap := mycs2;
                from_nons := froms2;
                sent_nons := sents2;
                cur_nonce := cur_n2 |}, iu, b0))).

      * (do 2 eexists); repeat simple apply conj; eauto.
        econstructor 1; eauto.
        econstructor; eauto.
        econstructor 2; eauto; simpl in *.

        unfold goodness_predicates in *; split_ex; simpl in *.
        specialize (H2 _ _ _ H5 eq_refl); split_ex.
        eapply action_matches_other_user_silent_step; eauto.

      * destruct x11 as [[ru1 iu1] b1].
        (do 2 eexists); repeat simple apply conj;
          [ solve [ econstructor 1; eauto ]
          | econstructor
          | ..
          ].
        econstructor 3; eauto.
        rewrite H25; eapply falsify_trace; eauto.
        eauto.
        destruct st'' as [p b2]; simpl.
        destruct b2; eauto.

    + destruct (uid ==n uid0); subst; clean_map_lookups; clear_mislabeled_steps.

      destruct userData; unfold buildUniverse, build_data_step in *; simpl in *.

      generalize H12; intros STEP
      ; eapply step_limited_change_other_user_qmsgs with (uid := uid) (uid' := uid0) in STEP
      ; eauto; split_ex.
      rename x into msg_heap'.

      specialize (IHstepsi _ _ H0); simpl in *.

      eapply silent_step_commutes_noblock with (usrs := users ru) (usrs1' := usrs0) in H6; eauto.
      2: clean_map_lookups; eauto.
      split_ex.

      generalize H6; intros SS; eapply IHstepsi in H6; eauto.
      clear IHstepsi; split_ex; subst.

      invert H6; clear_mislabeled_steps.

      pose proof (useless_summary_summarizes protocol0).
      eapply silent_step_na_commuting with (s := useless_summary) in SS; eauto
      ; split_ex.

      eapply commutes_sound with (u_id1 := uid0) (u_id2 := uid) in H17; eauto; simpl.

      split_ex; subst.
      unfold build_data_step in H17; destruct ru.
      dt x14; dt x15; destruct x16; simpl in *.

      eapply silent_step_labels_still_misaligned with (b := b0) (b' := b0) in H11; eauto.

      destruct x11 as [[ru1 iu1] b1].
      simpl in *.
      (do 2 eexists); repeat simple apply conj.
      econstructor 1; eauto.
      econstructor; eauto.
      econstructor 3; eauto.
      all: eauto.

    + destruct (uid ==n uid0); subst; clean_map_lookups; clear_mislabeled_steps.

      destruct userData; unfold buildUniverse, build_data_step in *; simpl in *.

      generalize H12; intros STEP
      ; eapply step_limited_change_other_user_qmsgs with (uid := uid) (uid' := uid0) in STEP
      ; eauto; split_ex.
      rename x into msg_heap'.

      specialize (IHstepsi _ _ H0); simpl in *.

      eapply silent_step_commutes_noblock with (usrs := users ru) (usrs1' := usrs0) in H6; eauto.
      2: clean_map_lookups; eauto.
      split_ex.

      generalize H6; intros SS; eapply IHstepsi in H6; eauto.
      clear IHstepsi; split_ex; subst.

      invert H6; clear_mislabeled_steps.

      pose proof (useless_summary_summarizes protocol0).
      eapply silent_step_na_commuting with (s := useless_summary) in SS; eauto
      ; split_ex.

      eapply commutes_sound with (u_id1 := uid0) (u_id2 := uid) in H17; eauto; simpl.

      split_ex; subst.
      unfold build_data_step in H17; destruct ru.
      dt x14; dt x15; destruct x16; simpl in *.

      eapply silent_step_labels_still_misaligned with (b := b0) (b' := b0) in H11; eauto.

      destruct x11 as [[ru1 iu1] b1].
      simpl in *.
      (do 2 eexists); repeat simple apply conj.
      econstructor 1; eauto.
      econstructor; eauto.
      econstructor 4; eauto.
      all: eauto.

Qed.

#[export] Hint Constructors indexedRealStep indexedIdealStep : core.

Lemma step_extra_user :
  forall A B C lbl suid bd bd',
    @step_user A B C lbl suid bd bd'

    -> forall cs cs' (usrs usrs': honest_users A) (adv adv' : user_data B) gks gks'
        (cmd cmd' : user_cmd C) ks ks' qmsgs qmsgs' mycs mycs'
        froms froms' sents sents' cur_n cur_n' uid cmdc,

      suid = Some uid
      -> usrs $? uid = Some (mkUserData ks cmdc qmsgs mycs froms sents cur_n)
      -> bd = (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, cmd)
      -> bd' = (usrs', adv', cs', gks', ks', qmsgs', mycs', froms', sents', cur_n', cmd')

      -> forall uid' ud',
          ~ In uid' usrs
          -> exists bd'',
            step_user lbl (Some uid)
                      (usrs $+ (uid',ud'), adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, cmd)
                      bd''.
Proof.
  induction 1; inversion 3; inversion 1; intros; subst
  ; try solve [ eexists; econstructor; eauto ]
  ; clean_context.

  eapply IHstep_user in H1; eauto.
  split_ex.
  dt x; eexists; econstructor; eauto.

  Unshelve.
  all: auto.
Qed.

Lemma silent_step_minus_user :
  forall A B C lbl suid bd bd',
    @step_user A B C lbl suid bd bd'

    -> forall cs cs' (usrs usrs': honest_users A) (adv adv' : user_data B) gks gks'
        (cmd cmd' : user_cmd C) ks ks' qmsgs qmsgs' mycs mycs'
        froms froms' sents sents' cur_n cur_n' uid cmdc uid' ud',

      ~ In uid' usrs
      -> suid = Some uid
      -> lbl = Silent
      -> usrs $? uid = Some (mkUserData ks cmdc qmsgs mycs froms sents cur_n)
      -> bd = (usrs $+ (uid',ud'), adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, cmd)
      -> bd' = (usrs', adv', cs', gks', ks', qmsgs', mycs', froms', sents', cur_n', cmd')

      -> exists bd'',
          step_user lbl (Some uid)
                    (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, cmd)
                    bd''.
Proof.
  induction 1; inversion 5; inversion 1; intros; subst
  ; try discriminate
  ; try solve [ eexists; econstructor; eauto ]
  ; clean_context.

  eapply IHstep_user in H3; eauto.
  split_ex.
  dt x; eexists; econstructor; eauto.

  Unshelve.
  all: auto.
Qed.

Lemma must_be_max_silent_step' :
  forall A B usrs adv cs gks ks qmsgs mycs froms sents cur_n cmd uid bd,
    usrs $? uid = Some (mkUserData ks cmd qmsgs mycs froms sents cur_n)
    -> @step_user A B (Base A) Silent (Some uid) (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, cmd) bd
    -> exists uid__max U__max',
        indexedRealStep uid__max Silent
                        {| users := usrs; adversary := adv; all_ciphers := cs; all_keys := gks |} U__max'
        /\ (forall uid' U',
              uid' > uid__max ->
              ~ indexedRealStep uid' Silent
                {| users := usrs; adversary := adv; all_ciphers := cs; all_keys := gks |} U').
Proof.
  intros A B usrs.
  induction usrs using O.map_induction_max; intros.

  - unfold Empty, Raw.Empty in H.
    rewrite <- find_mapsto_iff in H0.
    unfold MapsTo in H0.
    exfalso.
    eapply H; eauto.

  - unfold Add in H0.

    destruct (x ==n uid); subst; clean_map_lookups; eauto.

    + dt bd.
      clear IHusrs1.
      exists uid; eexists.
      split.
      econstructor; eauto.
      unfold not; intros.
      invert H4; simpl in *.
      unfold O.Above in H.
      specialize (H uid').
      specialize (H0 uid'); clean_map_lookups.
      destruct (uid ==n uid'); subst; try Nat.order.
      clean_map_lookups.
      assert (usrs1 $? uid' <> None) by (clean_map_lookups; eauto).
      rewrite <- in_find_iff in H4.
      apply H in H4; lia.

    + rewrite H0 in H1; clean_map_lookups.
      assert (usrs2 = usrs1 $+ (x,e))
        by (apply map_eq_Equal; unfold Equal; eauto).
      subst.

      unfold O.Above in H.
      destruct ( classic (In x usrs1) ).
      apply H in H3; lia.

      dt bd; pose proof (silent_step_minus_user H2 H3 eq_refl eq_refl H1 eq_refl eq_refl).
      split_ex.
      dt x0.

      generalize H4; intros; eapply IHusrs1 in H4; eauto.
      clear IHusrs1.
      split_ex.

      invert H4; simpl in *.
      destruct (x ==n x0); subst; clean_map_lookups.
      destruct userData
      ; unfold build_data_step in *
      ; simpl in *.

      destruct ( classic ( exists U', indexedRealStep x Silent (mkUniverse (usrs1 $+ (x,e)) adv cs gks) U' )).
      split_ex.

      * exists x; eexists.
        split; eauto.

        unfold not; intros.
        invert H10; simpl in *.
        destruct (x ==n uid'); try lia; clean_map_lookups; eauto.
        assert (usrs1 $? uid' <> None) by (clean_map_lookups).
        rewrite <- in_find_iff in H10.
        apply H in H10; lia.

      * eapply step_extra_user in H8; split_ex; eauto.
        dt x1.
        exists x0; eexists.
        split.
        econstructor; unfold build_data_step; simpl; eauto.

        intros.
        destruct (uid' ==n x); subst; clean_map_lookups.
        ** firstorder idtac.
        ** unfold not; intros.
           invert H10.
           destruct userData; unfold build_data_step in *; simpl in *; clean_map_lookups.
           eapply silent_step_minus_user in H12; eauto.
           split_ex; eauto.
           dt x1.

           eapply H6 in H9; eauto.

Qed.

Lemma must_be_max_silent_step :
  forall A B uid U U',
    @indexedRealStep A B uid Silent U U'
    -> exists uid__max U__max',
        indexedRealStep uid__max Silent U U__max'
        /\ (forall uid' U',
              uid' > uid__max ->
              ~ indexedRealStep uid' Silent U U').
Proof.
  intros.
  invert H.
  destruct U; destruct userData
  ; simpl in *
  ; eauto using must_be_max_silent_step'.
Qed.

Lemma violations_translate :
  forall t__hon t__adv n st st' b summaries,
    stepsi n st st'
    -> lameAdv b (fst (fst st)).(adversary)
    -> goodness_predicates (fst (fst st))
    -> syntactically_safe_U (fst (fst st))
    -> summarize_univ (fst (fst st)) summaries
    -> (forall st'', step st' st'' -> False)
    -> ~ ( no_resends_U (fst (fst st')) /\ alignment st' /\ returns_align st')
    -> exists st'',
        (@stepSS t__hon t__adv)^* st st''
        /\ ~ (no_resends_U (fst (fst st'')) /\ alignment st'' /\ returns_align st'').
Proof.
  induct n; intros.

  invert H; eexists; split; eauto.

  destruct (
      classic (exists uid U', indexedRealStep uid Silent (fst (fst st)) U')
    ).

  - split_ex.

    pose proof (must_be_max_silent_step H6); split_ex; clear x x0 H6.
    invert H7.
    eapply translate_trace_commute in H; eauto.

    split_ex; subst.
    generalize H; intros; eapply progress_predicates in H; eauto; split_ex.

    eapply IHn in H7;
      eauto using model_stuck_carent_alignment_bit,
                  violated_predicates_remain_violated;
      split_ex.

    exists x2; split; eauto.
    eapply TrcFront; eauto.
    destruct st as [[ru iu] v].
    destruct x  as [[ru' iu'] v'].
    simpl in *.

    econstructor.
    2-3: reflexivity.
    econstructor 1; eauto.

    unfold build_data_step in *; simpl in *; eauto.

  - invert H.

    generalize H8; intros SS;
      eapply syntactically_safe_U_preservation_step in SS; eauto.

    assert (SSU : syntactically_safe_U (fst (fst st'0))) by eauto using syntactically_safe_U_preservation_step.
    assert (GOODNESS : goodness_predicates (fst (fst st'0))) by eauto using goodness_preservation_step.

    eapply IHn in H9; eauto using summarize_univ_step.
    repeat match goal with
           | [ H : goodness_predicates _ |- _ ] => clear H
           | [ H : syntactically_safe_U _ |- _ ] => clear H
           end.
    firstorder idtac.
    simpl in *.

    exists x.
    unfold not; split; intros; split_ex; eauto 8.
    eapply TrcFront; eauto.
    destruct st as [[ru iu] v], st'0 as [[ru0' iu0'] v0'].

    generalize H8; intros STEP; invert H8;
      match goal with
      | [ H : step_universe _ _ _ _ |- _ ] => invert H
      | [ H : indexedRealStep _ _ _ _ |- _ ] => invert H
      end.

    + specialize (H5 u_id); firstorder idtac.
      unfold mkULbl in H10; destruct lbl; try discriminate.
      exfalso.
      eapply H5; simpl.
      econstructor; eauto.

    + destruct ru; unfold build_data_step, lameAdv in *; simpl in *.
      rewrite H0 in H6; invert H6.

    + econstructor; eauto.
      econstructor 2; eauto.

    + econstructor; eauto.
      econstructor 2; eauto.

    + econstructor; eauto.
      econstructor 2; eauto.
Qed.

Lemma complete_trace :
  forall t__hon t__adv n' n st b,
    runningTimeMeasure (fst (fst st)) n
    -> n <= n'
    -> lameAdv b (fst (fst st)).(adversary)
    -> exists st',
        (@step t__hon t__adv) ^* st st'
      /\ (forall st'', step st' st'' -> False).

Proof.
  induct n'; intros.
  - invert H; simpl in *.

    exists st; split; intros; eauto.
    destruct st as [[ru iu] v].
    destruct ru; simpl in *; subst.
    destruct n__rt; try lia.

    invert H.

    + invert H7; dismiss_adv; simpl in *.
      eapply boundRunningTime_for_element in H2; eauto; split_ex.
      destruct x; try lia.
      invert H2.
      unfold build_data_step in *; rewrite <- H9 in H3; invert H3.

    + invert H6; simpl in *.
      eapply boundRunningTime_for_element in H2; eauto; split_ex.
      destruct x; try lia.
      invert H2.
      unfold build_data_step in *; rewrite <- H12 in H3; invert H3.

    + invert H6; simpl in *.
      eapply boundRunningTime_for_element in H2; eauto; split_ex.
      destruct x; try lia.
      invert H2.
      unfold build_data_step in *; rewrite <- H11 in H3; invert H3.

    + invert H6; simpl in *.
      eapply boundRunningTime_for_element in H2; eauto; split_ex.
      destruct x; try lia.
      invert H2.
      unfold build_data_step in *; rewrite <- H11 in H3; invert H3.

  - destruct (classic (exists st', step st st')).
    + split_ex.
      rename x into st'.
      assert (LAME' : lameAdv b (fst (fst st')).(adversary)) by eauto using adversary_remains_lame_step.
      eapply runningTimeMeasure_step in H; eauto; split_ex.

      eapply IHn' in H; try lia; eauto.
      split_ex.
      exists x0; split; intros; eauto.

    + firstorder idtac; simpl in *.
      exists st; split; intros; eauto.
Qed.

#[export] Hint Resolve  goodness_preservation_step syntactically_safe_U_preservation_step : core.

Lemma many_steps_stays_lame :
  forall t__hon t__adv st st' b,
    (@step t__hon t__adv) ^* st st'
    -> lameAdv b (adversary (fst (fst st)))
    -> lameAdv b (adversary (fst (fst st'))).
Proof.
  induction 1;
    intros;
    simpl in *;
    eauto.
Qed.

Lemma many_steps_syntactically_safe :
  forall t__hon t__adv st st',
    (@step t__hon t__adv) ^* st st'
    -> syntactically_safe_U (fst (fst st))
    -> goodness_predicates (fst (fst st))
    -> syntactically_safe_U (fst (fst st')).
Proof.
  induction 1;
    intros;
    simpl in *;
    eauto.
Qed.

Lemma many_steps_stays_good :
  forall t__hon t__adv st st',
    (@step t__hon t__adv) ^* st st'
    -> goodness_predicates (fst (fst st))
    -> syntactically_safe_U (fst (fst st))
    -> goodness_predicates (fst (fst st')).
Proof.
  induction 1;
    intros;
    simpl in *;
    eauto.
Qed.

#[export] Hint Resolve many_steps_stays_lame many_steps_syntactically_safe many_steps_stays_good : core.

Locate safety.

Theorem step_stepSS' :
  forall {t__hon t__adv} (ru0 : RealWorld.universe t__hon t__adv) (iu0 : IdealWorld.universe t__hon) b n summaries,
    runningTimeMeasure ru0 n
    -> goodness_predicates ru0
    -> syntactically_safe_U ru0
    -> summarize_univ ru0 summaries
    -> lameAdv b ru0.(adversary)
    -> invariantFor (TrSS ru0 iu0) (fun st => no_resends_U (fst (fst st)) /\ alignment st /\ returns_align st)
    -> invariantFor (TrS ru0 iu0) (fun st => no_resends_U (fst (fst st)) /\ alignment st /\ returns_align st)
.
Proof.
  intros * RUNTIME GOOD SYN_SAFE SUMM LAME INV.

  apply NNPP; unfold not; intros INV'.
  unfold invariantFor in INV'.
  apply not_all_ex_not in INV'; split_ex.
  apply imply_to_and in H; split_ex.
  apply not_all_ex_not in H0; split_ex.
  apply imply_to_and in H0; split_ex.
  simpl in H; split_ors; try contradiction.
  destruct x0 as [[?ru ?iu] ?v].

  subst; simpl in *.

  assert (exists n', runningTimeMeasure (fst (fst (ru, iu, v))) n' /\ n' <= n)
    by eauto using runningTimeMeasure_steps; split_ex.

  eapply complete_trace in H; eauto; split_ex.
  specialize (trc_trans H0 H); intros.
  apply steps_stepsi in H4; split_ex.

  unfold invariantFor in INV; simpl in *.
  eapply violations_translate in H4; eauto; split_ex.
  apply INV in H4; eauto; split_ex.

  eapply not_and_or in H1
  ; destruct H1 as [H1 | H1]
  ; [ | eapply not_and_or in H1]
  ; split_ors
  ; simpl
  ; unfold not; intros; split_ex.

  - assert (~ no_resends_U (fst (fst x0)))
      by eauto using resend_violation_steps
    ; contradiction.

  - assert (~ alignment x0)
      by eauto using alignment_violation_steps
    ; contradiction.

  - assert (~ returns_align x0)
      by eauto using final_alignment_violation_steps
    ; contradiction.
Qed.

Lemma ss_implies_next_safe :
  forall t (cmd : user_cmd t) uid ctx uids sty cs,
    syntactically_safe uid uids ctx cmd sty
    -> forall A B (usrs usrs' : honest_users A) (adv adv' : user_data B) cmd'
        cs' gks gks' ks ks' qmsgs qmsgs' mycs mycs' froms froms' sents sents' n n' lbl,
      step_user lbl (Some uid)
                (usrs,adv,cs,gks,ks,qmsgs,mycs,froms,sents,n,cmd)
                (usrs',adv',cs',gks',ks',qmsgs',mycs',froms',sents',n',cmd')
      -> typingcontext_sound ctx usrs cs uid
      -> uids = compute_ids usrs
      -> forall t__n (cmd__n : user_cmd t__n), nextAction cmd cmd__n
      -> (forall r, cmd__n <> Return r)
      -> no_resends sents'
      -> next_cmd_safe (findUserKeys usrs) cs uid froms sents cmd.
Proof.
  induct cmd;
    unfold next_cmd_safe; intros;
      match goal with
      | [ H : nextAction _ _ |- _ ] => invert H
      end; eauto;
        try solve [ unfold typingcontext_sound in *; split_ex;
                    match goal with
                    | [ H : syntactically_safe _ _ _ _ _ |- _ ] => invert H
                    end; eauto ].

  - invert H0.
    invert H1; eauto.
    invert H4.
    eapply IHcmd in H7; eauto.
    eapply H7 in H11; eauto.

    invert H11; trivial.

  - unfold typingcontext_sound in *; split_ex; invert H.
    apply H2 in H11; split_ex; subst.
    apply H1 in H10.
    unfold msg_honestly_signed, msg_signing_key,
           msg_to_this_user, msg_destination_user,
           honest_keyb;
      context_map_rewrites.
    destruct ( cipher_to_user x0 ==n cipher_to_user x0 ); try contradiction.
    repeat simple apply conj; eauto.
    econstructor; eauto.
    unfold msg_honestly_signed, msg_signing_key, honest_keyb;
      context_map_rewrites;
      trivial.
    (do 2 eexists); repeat simple apply conj; eauto.
    invert H0.
    unfold no_resends, updateSentNonce in H5; context_map_rewrites.
    destruct (cipher_to_user x0 ==n cipher_to_user x0); try contradiction.
    invert H5; eauto.

  - unfold typingcontext_sound in *; split_ex; invert H; eauto.
    intros.
    apply H12 in H; split_ex; subst; eauto.
Qed.

Lemma step_na_recur :
  forall t t__n (cmd : user_cmd t) (cmd__n : user_cmd t__n),
    nextAction cmd cmd__n
    -> forall A B suid lbl bd bd',

      step_user lbl suid bd bd'

      -> forall cs cs' (usrs usrs': honest_users A) (adv adv' : user_data B) gks gks'
          cmd__n' ks ks' qmsgs qmsgs' mycs mycs'
          froms froms' sents sents' cur_n cur_n',

        bd = (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, cmd__n)
        -> bd' = (usrs', adv', cs', gks', ks', qmsgs', mycs', froms', sents', cur_n', cmd__n')
        -> exists bd'',
            step_user lbl suid (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, cmd) bd''.
Proof.
  induct 1; intros; subst;
    eauto.

  eapply IHnextAction in H0; eauto. split_ex.
  simpl.

  dt x; eexists; eapply StepBindRecur; eauto.
Qed.

Lemma ss_implies_next_safe_no_model_step :
  forall A B (usrs : honest_users A) (adv : user_data B) cs gks
    cmd uid ctx uids sty,

    uids = compute_ids usrs
    -> forall ks qmsgs mycs froms sents cur_n, usrs $? uid = Some (mkUserData ks cmd qmsgs mycs froms sents cur_n)
    -> forall t__n (cmd__n : user_cmd t__n), nextAction cmd cmd__n
    -> syntactically_safe uid uids ctx cmd sty
    -> typingcontext_sound ctx usrs cs uid
    -> forall ru iu, ru = mkUniverse usrs adv cs gks
    -> (forall ru' iu', indexedModelStep uid (ru,iu,true) (ru',iu',true) -> False)
    -> labels_align (ru,iu,true)
    -> next_cmd_safe (findUserKeys usrs) cs uid froms sents cmd.
Proof.
  intros.
  cases cmd__n;
    unfold next_cmd_safe; intros;
      match goal with
      | [ H1 : nextAction cmd _, H2 : nextAction cmd _ |- _ ] => eapply na_deterministic in H1; eauto
      end; split_ex; subst; trivial.

  Ltac xyz :=
    repeat
      match goal with
      | [ NA : nextAction _ (Bind _ _) |- _ ] =>
        eapply nextAction_couldBe in NA; contradiction
      | [ SS : syntactically_safe _ _ _ ?cmd _, NA : nextAction ?cmd _ |- _ ] =>
        eapply syntactically_safe_na in SS; eauto; split_ex
      | [ SS : syntactically_safe _ _ _ _ _ |- _ ] =>
        invert SS; unfold typingcontext_sound in *; split_ex; process_ctx
      end.

  all: xyz; eauto.

  - exfalso.

    assert (SEND : exists lbl bd,
               step_user lbl
                         (Some uid)
                         (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n,
                          @Send t0 (cipher_to_user x0) (SignedCiphertext x)) bd).
      (do 2 eexists); econstructor; clean_map_lookups; simpl in *; eauto.
      context_map_rewrites; eauto.
      unfold not; intros INV; invert INV; contradiction.
      split_ex.

      destruct x1.
      invert H4.

      dt x3.
      eapply step_na_recur in H4; eauto; split_ex.
      dt x1.

      assert (exists ru', indexedRealStep uid (Action a)
                                     (mkUniverse usrs adv cs gks)
                                     ru')
        by (eexists; econstructor; eauto).

      split_ex.
      generalize (H6 _ _ _ H8); intros; split_ex.
      eapply H5; clear H5.
      econstructor 2; eauto.

  - eapply H11 in H4; split_ex.
    eapply H in H4; eauto.
Qed.

Lemma indexedModelStep_step :
  forall t__hon t__adv uid st st',
    @indexedModelStep t__hon t__adv uid st st'
    -> step st st'.
Proof.
  intros.
  invert H; [
    econstructor 1
  | econstructor 2
  | econstructor 3
  | econstructor 4 ]; eauto.

  invert H0; econstructor; eauto.
Qed.

Theorem step_stepSS :
  forall {t__hon t__adv} (ru0 : RealWorld.universe t__hon t__adv) (iu0 : IdealWorld.universe t__hon) b n summaries,
    runningTimeMeasure ru0 n
    -> goodness_predicates ru0
    -> syntactically_safe_U ru0
    -> summarize_univ ru0 summaries
    -> lameAdv b ru0.(adversary)
    -> invariantFor (TrS ru0 iu0) (fun st => no_resends_U (fst (fst st)) /\ alignment st /\ returns_align st)
    -> invariantFor (TrS ru0 iu0) (fun st => safety st /\ alignment st /\ returns_align st)
.
Proof.
  unfold invariantFor; intros.
  specialize (H4 _ H5).
  generalize H6; intros STEPS; eapply H4 in H6; eauto.
  split_ex; split; eauto.

  destruct s' as [[ru' iu'] b'].
  simpl in *; split_ex; subst.
  split_ors; try contradiction; subst.

  hnf in H7; split_ex; simpl in H5; subst.
  assert (SS : syntactically_safe_U (fst (fst (ru', iu', true)))) by eauto.
  unfold honest_cmds_safe; intros.

  destruct (classic (exists st, indexedModelStep u_id (ru',iu',true) (st,true))).
  - split_ex.
    destruct x as [ru'' iu''].
    pose proof (indexedModelStep_step H10) as STEP.
    assert (STEPS' : (@step t__hon t__adv) ^* (ru',iu',true) (ru'',iu'',true)) by (eauto using TrcFront).
    pose proof (trc_trans STEPS STEPS') as MORESTEPS.

    specialize (H4 _ MORESTEPS); unfold no_resends_U in H4.
    simpl in *; split_ex.

    unfold syntactically_safe_U in SS;
      specialize (SS _ _ _ H9 eq_refl); split_ex.

    assert (exists lbl, indexedRealStep u_id lbl ru' ru'') by (invert H10; eauto).
    split_ex.
    invert H15.

    unfold build_data_step, buildUniverse in *; simpl in *.
    clean_map_lookups.

    pose proof (na_always_exists (protocol userData)); split_ex.
    destruct (classic (exists r, x3 = Return r)); split_ex; subst; eauto.
    + unfold next_cmd_safe; intros.
      eapply na_deterministic in H5; eauto.
      split_ex; subst; trivial.

    + rewrite Forall_natmap_forall in H4.
      specialize (H4 u_id).
      rewrite add_eq_o in H4 by trivial.
      specialize (H4 _ eq_refl); simpl in H4.
      eapply ss_implies_next_safe;
        eauto.

  - assert (forall st, indexedModelStep u_id (ru',iu',true) (st,true) -> False) by eauto using not_ex_all_not.

    subst.
    clear H10.
    unfold syntactically_safe_U in SS.
      specialize (SS _ _ _ H9 eq_refl); split_ex.
    simpl in *.

    pose proof (na_always_exists (protocol u)); split_ex.

    destruct ru', u;
      simpl in *;
      eapply ss_implies_next_safe_no_model_step; eauto.

Qed.

Module Type AutomatedSafeProtocolSS.
  Parameter t__hon : type.
  Parameter t__adv : type.
  Parameter b : << Base t__adv >>.
  Parameter iu0 : IdealWorld.universe t__hon.
  Parameter ru0 : RealWorld.universe t__hon t__adv.
  (* Parameter runTime : nat. *)
  (* Parameter summaries : NatMap.t summary. *)

  Notation SYS := (TrSS ru0 iu0).

  Axiom U_good : universe_starts_sane b ru0.
  Axiom universe_starts_safe : universe_ok ru0.

  Axiom finitelyRuns : exists n, runningTimeMeasure ru0 n.
  (* Axiom finitelyRuns : runningTimeMeasure ru0 runTime. *)
  Axiom typechecks : syntactically_safe_U ru0.
  Axiom summarizable : exists summaries, summarize_univ ru0 summaries.
  (* Axiom summarizable : summarize_univ ru0 summaries. *)
  Axiom lameness : lameAdv b (adversary ru0).

  Axiom safe_invariant : invariantFor
                           SYS
                           (fun st => no_resends_U (fst (fst st)) /\ alignment st /\ returns_align st).
End AutomatedSafeProtocolSS.

Module SSProtocolSimulates (Proto : AutomatedSafeProtocolSS).
  Import Proto Simulation.

  Module SSAutomatedSafeProtocol <: AutomatedSafeProtocol.
    Definition t__hon := t__hon.
    Definition t__adv := t__adv.
    Definition b := b.
    Definition iu0 := iu0.
    Definition ru0 := ru0.

    Lemma U_good : universe_starts_sane b ru0.
    Proof. exact U_good. Qed.

    Lemma universe_starts_safe : universe_ok ru0.
    Proof. exact universe_starts_safe. Qed.

    Lemma goodness_predicates_ok : goodness_predicates ru0.
    Proof. pose proof universe_starts_safe; unfold universe_ok, goodness_predicates, adv_goodness in *
           ; intuition idtac.

           unfold adv_message_queue_ok in H4
           ; rewrite Forall_forall in H4 |- *
           ; intros * LIN
           ; apply H4 in LIN.

           - destruct x; split_ex; split; eauto.
             intros.
             apply H11 in H12; split_ex; eauto.
           - unfold adv_cipher_queue_ok in H3
             ; rewrite Forall_forall in H3 |- *
             ; intros * LIN
             ; apply H3 in LIN
             ; split_ex
             ; eauto.
    Qed.

    #[local] Hint Resolve goodness_predicates_ok : core.
    #[local] Hint Resolve typechecks lameness Proto.safe_invariant : core.

    Lemma safe_invariant :
      invariantFor
        (TrS ru0 iu0)
        (fun st => safety st /\ alignment st /\ returns_align st).
    Proof.
      pose proof (@step_stepSS Proto.t__hon Proto.t__adv).
      pose proof finitelyRuns.
      pose proof summarizable.
      split_ex.
      eapply H; eauto.

      pose proof (@step_stepSS' Proto.t__hon Proto.t__adv); eauto.
    Qed.

  End SSAutomatedSafeProtocol.

  Module Import SSSimulates := ProtocolSimulates ( SSAutomatedSafeProtocol ).

  Lemma protocol_with_adversary_could_generate_spec :
    forall U__ra advcode acts__r,
      U__ra = add_adversary ru0 advcode
      -> rCouldGenerate U__ra acts__r
      -> exists acts__i,
          iCouldGenerate iu0 acts__i
          /\ traceMatches acts__r acts__i.
  Proof.
    eauto using SSSimulates.protocol_with_adversary_could_generate_spec.
  Qed.

End SSProtocolSimulates.


From VLSM.Lib Require Import Itauto.
From Coq Require Import Reals.
From stdpp Require Import prelude.
From VLSM.Lib Require Import Preamble StdppExtras StdppListFinSet FinSetExtras.
From VLSM.Lib Require Import ListExtras ListSetExtras Measurable.
From VLSM.Core Require Import VLSM AnnotatedVLSM MessageDependencies VLSMProjections Composition.
From VLSM.Core Require Import Validator ProjectionTraces SubProjectionTraces Equivocation.
From VLSM.Core Require Import Equivocation.FixedSetEquivocation.
From VLSM.Core Require Import Equivocation.LimitedMessageEquivocation.
From VLSM.Core Require Import Equivocation.MsgDepFixedSetEquivocation.
From VLSM.Core Require Import Equivocation.TraceWiseEquivocation.

(**
  To allow capturing the two models of limited equivocation described in the
  sections below, we first define a notion of limited equivocation parameterized
  on a function yielding the set of equivocators induced by a received message,
  other that the message sender.
*)

Section sec_coequivocating_senders_limited_equivocation.

Context
  {message : Type}
  `{finite.Finite index}
  (IM : index -> VLSM message)
  (threshold : R)
  `{ReachableThreshold validator Cv threshold}
  (A : validator -> index)
  (sender : message -> option validator)
  (coequivocating_senders : composite_state IM -> message -> Cv)
  `{forall i, HasBeenSentCapability (IM i)}
  `{forall i, HasBeenReceivedCapability (IM i)}
  .

Definition coeqv_message_equivocators (s : composite_state IM) (m : message)
  : Cv :=
  if decide (composite_has_been_directly_observed IM s m)
  then (* no additional equivocation *)
    ∅
  else (* m itself and all its non-observed dependencies are equivocating. *)
    list_to_set (map_option sender [m] ++ (elements (coequivocating_senders s m))).

Definition coeqv_composite_transition_message_equivocators
  (l : composite_label IM)
  (som : annotated_state (free_composite_vlsm IM) Cv * option message)
  : Cv :=
  match som with
  | (sa, None) => state_annotation sa
  | (sa, Some m) =>
    (state_annotation sa) ∪ (coeqv_message_equivocators (original_state sa) m)
  end.

Definition coeqv_limited_equivocation_constraint
  (l : composite_label IM)
  (som : annotated_state (free_composite_vlsm IM) Cv * option message)
  : Prop :=
  (sum_weights (coeqv_composite_transition_message_equivocators l som) <= threshold)%R.

#[export] Program Instance empty_validators_inhabited : Inhabited {s : Cv | s = ∅} :=
  populate (exist _ ∅ _).
Next Obligation.
Proof. done. Defined.

Definition coeqv_limited_equivocation_vlsm : VLSM message :=
  annotated_vlsm (free_composite_vlsm IM) Cv (fun s => s = ∅)
    coeqv_limited_equivocation_constraint coeqv_composite_transition_message_equivocators.

Definition coeqv_annotate_trace_with_equivocators :=
  annotate_trace (free_composite_vlsm IM) Cv (fun s => s = ∅)
    coeqv_composite_transition_message_equivocators.

Lemma coeqv_limited_equivocation_transition_state_annotation_incl [l s iom s' oom]
  : vtransition coeqv_limited_equivocation_vlsm l (s, iom) = (s', oom) ->
    state_annotation s ⊆ state_annotation s'.
Proof.
  cbn; unfold annotated_transition; destruct (vtransition _ _ _) as (_s', _om').
  inversion 1; cbn.
  by destruct iom as [m |]; [apply union_subseteq_l |].
Qed.

Lemma coeqv_limited_equivocation_state_annotation_nodup s
  : valid_state_prop coeqv_limited_equivocation_vlsm s ->
    NoDup (elements (state_annotation s)).
Proof.
  induction 1 using valid_state_prop_ind.
  - by destruct s, Hs as [_ ->]; cbn in *; apply NoDup_elements.
  - destruct Ht as [_ Ht]; cbn in Ht.
    unfold annotated_transition in Ht
    ; destruct (vtransition _ _ _); inversion Ht; apply NoDup_elements.
Qed.

Lemma coeqv_limited_equivocation_state_not_heavy s
  : valid_state_prop coeqv_limited_equivocation_vlsm s ->
    (sum_weights (state_annotation s) <= threshold)%R.
Proof.
  induction 1 using valid_state_prop_ind.
  - destruct s, Hs as [_ ->]; cbn in *.
    rewrite sum_weights_empty; [| done].
    by apply (rt_positive (H6 := H7)).
  - destruct Ht as [(_ & _ & _ & Hc) Ht]
    ; cbn in Ht; unfold annotated_transition in Ht; destruct (vtransition _ _ _)
    ; inversion_clear Ht.
    by destruct om as [m |].
Qed.

Definition coeqv_limited_equivocation_projection_validator_prop : index -> Prop :=
  annotated_projection_validator_prop IM (fun s => s = ∅)
    coeqv_limited_equivocation_constraint coeqv_composite_transition_message_equivocators.

Definition coeqv_limited_equivocation_message_validator_prop : index -> Prop :=
  annotated_message_validator_prop IM (fun s => s = ∅)
    coeqv_limited_equivocation_constraint coeqv_composite_transition_message_equivocators.

Definition coeqv_limited_equivocation_projection_validator_prop_alt : index -> Prop :=
  annotated_projection_validator_prop_alt IM (fun s => s = ∅)
    coeqv_limited_equivocation_constraint coeqv_composite_transition_message_equivocators.

End sec_coequivocating_senders_limited_equivocation.

Section sec_msg_dep_limited_equivocation.

Context
  {message : Type}
  `{finite.Finite index}
  (IM : index -> VLSM message)
  `{forall i, HasBeenSentCapability (IM i)}
  `{forall i, HasBeenReceivedCapability (IM i)}
  (threshold : R)
  `{ReachableThreshold validator Cv threshold}
  `{FinSet message Cm}
  (full_message_dependencies : message -> Cm)
  (A : validator -> index)
  (sender : message -> option validator)
  .

Definition not_directly_observed_happens_before_dependencies (s : composite_state IM) (m : message)
  : Cm :=
  filter (fun dm => ~ composite_has_been_directly_observed IM s dm) (full_message_dependencies m).

Definition msg_dep_coequivocating_senders (s : composite_state IM) (m : message)
  : Cv :=
  list_to_set (map_option sender (elements (not_directly_observed_happens_before_dependencies s m))).

Definition msg_dep_limited_equivocation_vlsm : VLSM message :=
  coeqv_limited_equivocation_vlsm IM threshold sender msg_dep_coequivocating_senders.

Definition msg_dep_message_equivocators :=
  coeqv_message_equivocators IM sender msg_dep_coequivocating_senders.

Definition msg_dep_annotate_trace_with_equivocators :=
  coeqv_annotate_trace_with_equivocators IM sender msg_dep_coequivocating_senders.

Lemma msg_dep_annotate_trace_with_equivocators_app : forall sa tr1 tr2,
  msg_dep_annotate_trace_with_equivocators sa (tr1 ++ tr2)
    =
  msg_dep_annotate_trace_with_equivocators sa tr1 ++
    annotate_trace_from (free_composite_vlsm IM) Cv
      (coeqv_composite_transition_message_equivocators IM sender msg_dep_coequivocating_senders)
      (@finite_trace_last _ (annotated_type (free_composite_vlsm IM) Cv)
        {| original_state := sa; state_annotation := ` inhabitant |}
        (msg_dep_annotate_trace_with_equivocators sa tr1)) tr2.
Proof. by intros; apply annotate_trace_from_app. Qed.

Lemma msg_dep_annotate_trace_with_equivocators_last_original_state : forall s s' tr,
  original_state (finite_trace_last s (msg_dep_annotate_trace_with_equivocators s' tr))
    =
  finite_trace_last (original_state s) tr.
Proof. by intros; apply annotate_trace_from_last_original_state. Qed.

Definition msg_dep_composite_transition_message_equivocators :=
  coeqv_composite_transition_message_equivocators IM sender msg_dep_coequivocating_senders.

Definition msg_dep_limited_equivocation_projection_validator_prop :=
  coeqv_limited_equivocation_projection_validator_prop IM threshold sender msg_dep_coequivocating_senders.

Definition msg_dep_limited_equivocation_message_validator_prop :=
  coeqv_limited_equivocation_message_validator_prop IM threshold sender msg_dep_coequivocating_senders.

Definition msg_dep_limited_equivocation_projection_validator_prop_alt :=
  coeqv_limited_equivocation_projection_validator_prop_alt IM threshold sender msg_dep_coequivocating_senders.

Lemma msg_dep_annotate_trace_with_equivocators_project s tr
  : pre_VLSM_embedding_finite_trace_project (type msg_dep_limited_equivocation_vlsm)
    (composite_type IM) Datatypes.id original_state
    (msg_dep_annotate_trace_with_equivocators s tr) = tr.
Proof. by apply (annotate_trace_project (free_composite_vlsm IM) Cv). Qed.

End sec_msg_dep_limited_equivocation.

Section sec_full_node_limited_equivocation.

Context
  {message : Type}
  `{finite.Finite index}
  (IM : index -> VLSM message)
  `{forall i, HasBeenSentCapability (IM i)}
  `{forall i, HasBeenReceivedCapability (IM i)}
  (threshold : R)
  `{ReachableThreshold validator Cv threshold}
  (A : validator -> index)
  (sender : message -> option validator)
  .

Definition full_node_coequivocating_senders (s : composite_state IM) (m : message)
  : Cv := ∅.

Definition full_node_limited_equivocation_vlsm : VLSM message :=
  coeqv_limited_equivocation_vlsm IM threshold sender full_node_coequivocating_senders.

End sec_full_node_limited_equivocation.

Section sec_full_node_msg_dep_limited_equivocation_equivalence.

Context
  {message : Type}
  `{FinSet message Cm}
  `{finite.Finite index}
  (IM : index -> VLSM message)
  `{forall i, HasBeenSentCapability (IM i)}
  `{forall i, HasBeenReceivedCapability (IM i)}
  (full_message_dependencies : message -> Cm)
  (threshold : R)
  `{ReachableThreshold validator Cv threshold}
  `{!LeibnizEquiv Cv}
  (A : validator -> index)
  (sender : message -> option validator)
  (message_dependencies : message -> Cm)
  `{!FullMessageDependencies message_dependencies full_message_dependencies}
  `{forall i, MessageDependencies (IM i) message_dependencies}
  (Hfull : forall i, message_dependencies_full_node_condition_prop (IM i) message_dependencies)
  (Limited := msg_dep_limited_equivocation_vlsm IM threshold full_message_dependencies sender (Cv := Cv))
  (FullNodeLimited := full_node_limited_equivocation_vlsm IM threshold sender (Cv := Cv))
  .

Lemma full_node_msg_dep_coequivocating_senders s m i li
  (Hvalid : input_valid (pre_loaded_with_all_messages_vlsm (IM i)) li (s i, Some m))
  : msg_dep_coequivocating_senders IM full_message_dependencies sender s m ≡@{Cv} ∅.
Proof.
  intro; split; intro Hx; [| by contradict Hx; apply not_elem_of_empty].
  exfalso; contradict Hx.
  unfold msg_dep_coequivocating_senders.
  rewrite elem_of_list_to_set, elem_of_map_option.
  setoid_rewrite elem_of_elements; setoid_rewrite elem_of_filter.
  intros (dm & [Hnobs Hdm]  & _).
  contradict Hnobs; exists i.
  eapply msg_dep_full_node_input_valid_happens_before_has_been_directly_observed;
    [by typeclasses eauto | by apply Hfull | done |].
  by apply full_message_dependencies_happens_before.
Qed.

Lemma annotated_free_input_valid_projection
  iprop `{Inhabited (sig iprop)} constr trans
  i li s om
  : input_valid (annotated_vlsm (free_composite_vlsm IM) Cv iprop constr trans)
      (existT i li) (s, om) ->
    input_valid (pre_loaded_with_all_messages_vlsm (IM i)) li (original_state s i, om).
Proof.
  intro Hvalid.
  eapply (VLSM_projection_input_valid (preloaded_component_projection IM i))
  ; [by apply (composite_project_label_eq IM) |].
  by apply
    (VLSM_incl_input_valid (vlsm_incl_pre_loaded_with_all_messages_vlsm (free_composite_vlsm IM))),
    (VLSM_embedding_input_valid (forget_annotations_projection (free_composite_vlsm IM) _ _ _)).
Qed.

Lemma full_node_msg_dep_composite_transition_message_equivocators
  i li (s : @state _ (annotated_type (free_composite_vlsm IM) Cv)) om
  (Hvalid : input_valid (pre_loaded_with_all_messages_vlsm (IM i)) li (original_state s i, om))
  : coeqv_composite_transition_message_equivocators
      IM sender (full_node_coequivocating_senders IM)
      (existT i li) (s, om)
      ≡
    msg_dep_composite_transition_message_equivocators
      IM full_message_dependencies sender
      (existT i li) (s, om).
Proof.
  destruct om as [m |]; cbn; [| done].
  apply sets.union_proper; [done |].
  unfold coeqv_message_equivocators, msg_dep_coequivocating_senders.
  case_decide as Hobs; [done |].
  remember (list_to_set (map_option _ _)) as equivs.
  cut (equivs ≡@{Cv} ∅); [by intros -> |].
  by subst; eapply full_node_msg_dep_coequivocating_senders.
Qed.

Lemma msg_dep_full_node_valid_iff
  l (s : @state _ (annotated_type (free_composite_vlsm IM) Cv)) om
  (Hvi : input_valid (pre_loaded_with_all_messages_vlsm (IM (projT1 l)))
           (projT2 l) (original_state s (projT1 l), om))
  : vvalid Limited l (s, om) <-> vvalid FullNodeLimited l (s, om).
Proof.
  cbn; unfold annotated_valid, coeqv_limited_equivocation_constraint; destruct l as [i li].
  replace (sum_weights _) with
    (sum_weights
      (coeqv_composite_transition_message_equivocators IM sender
        (full_node_coequivocating_senders IM) (existT i li)
        (s, om)));
    [done |].
  by apply sum_weights_proper, full_node_msg_dep_composite_transition_message_equivocators.
Qed.

Lemma msg_dep_full_node_transition_iff
  l (s : @state _ (annotated_type (free_composite_vlsm IM) Cv)) om
  (Hvi : input_valid (pre_loaded_with_all_messages_vlsm (IM (projT1 l)))
           (projT2 l) (original_state s (projT1 l), om))
  : vtransition Limited l (s, om) = vtransition FullNodeLimited l (s, om).
Proof.
  cbn; unfold annotated_transition;
    destruct (vtransition _ _ _) as (s', om'), l as (i, li).
  do 2 f_equal.
  destruct om as [m |]; [| done].
  symmetry.
  by apply leibniz_equiv, full_node_msg_dep_composite_transition_message_equivocators.
Qed.

Lemma msg_dep_full_node_limited_equivocation_vlsm_incl :
  VLSM_incl Limited FullNodeLimited.
Proof.
  apply basic_VLSM_incl.
  - by intros s Hs.
  - by intros _ _ m _ _ Hinit; apply initial_message_is_valid.
  - intros [i li] s om HvX _ _.
    apply msg_dep_full_node_valid_iff; [| apply HvX].
    by eapply annotated_free_input_valid_projection.
  - intros [i li] s iom s' oom [Hv Ht]; cbn in Ht |- *; rewrite <- Ht.
    symmetry; rapply msg_dep_full_node_transition_iff.
    by eapply annotated_free_input_valid_projection.
Qed.

Lemma full_node_msg_dep_limited_equivocation_vlsm_incl :
  VLSM_incl FullNodeLimited Limited.
Proof.
  apply basic_VLSM_incl.
  - by intros s Hs.
  - by intros _ _ m _ _ Hinit; apply initial_message_is_valid.
  - intros [i li] s om HvX _ _.
    apply msg_dep_full_node_valid_iff; [| apply HvX].
    by eapply annotated_free_input_valid_projection.
  - intros [i li] s iom s' oom [Hv Ht]; cbn in Ht |- *; rewrite <- Ht.
    rapply msg_dep_full_node_transition_iff.
    by eapply annotated_free_input_valid_projection.
Qed.

Lemma full_node_msg_dep_limited_equivocation_vlsm_eq :
  VLSM_eq FullNodeLimited Limited.
Proof.
  split.
  - by apply full_node_msg_dep_limited_equivocation_vlsm_incl.
  - by apply msg_dep_full_node_limited_equivocation_vlsm_incl.
Qed.

End sec_full_node_msg_dep_limited_equivocation_equivalence.

Section sec_msg_dep_fixed_limited_equivocation.

Context
  {message : Type}
  `{FinSet index Ci}
  `{!finite.Finite index}
  `{FinSet message Cm}
  (IM : index -> VLSM message)
  `{forall i, HasBeenSentCapability (IM i)}
  `{forall i, HasBeenReceivedCapability (IM i)}
  (message_dependencies : message -> Cm)
  (full_message_dependencies : message -> Cm)
  `{!FullMessageDependencies message_dependencies full_message_dependencies}
  `{forall i, MessageDependencies (IM i) message_dependencies}
  (threshold : R)
  `{ReachableThreshold validator Cv threshold}
  (sender : message -> option validator)
  (A : validator -> index)
  `{!Inj (=) (=) A}
  (Limited := msg_dep_limited_equivocation_vlsm IM threshold full_message_dependencies sender (Cv := Cv))
  (no_initial_messages_in_IM : no_initial_messages_in_IM_prop IM)
  (Hchannel : channel_authentication_prop IM A sender)
  (Hsender_safety : sender_safety_alt_prop IM A sender :=
    channel_authentication_sender_safety _ _ _ Hchannel)
  .

Lemma equivocating_messages_are_equivocator_emitted
  s im
  (Him : can_emit (free_composite_vlsm IM) im)
  (Hnobserved : ¬ composite_has_been_directly_observed IM s im) :
    exists v : validator,
      v ∈ msg_dep_message_equivocators IM full_message_dependencies sender s im (Cv := Cv)
        /\
      can_emit (pre_loaded_vlsm (IM (A v)) (fun dm => msg_dep_rel message_dependencies dm im)) im.
Proof.
  eapply (VLSM_incl_can_emit (vlsm_incl_pre_loaded_with_all_messages_vlsm (free_composite_vlsm IM)))
      in Him.
  apply can_emit_composite_project in Him as [j Him].
  apply Hchannel in Him as Hsender.
  unfold channel_authenticated_message in Hsender.
  destruct (sender im) as [v |] eqn: Heq_sender; [| by inversion Hsender].
  apply Some_inj in Hsender; cbn in Hsender; subst.
  exists v; subst; cbn.
  unfold msg_dep_message_equivocators, coeqv_message_equivocators,
         msg_dep_coequivocating_senders, not_directly_observed_happens_before_dependencies.
  rewrite decide_False by done; cbn.
  split.
  - by rewrite Heq_sender, elem_of_list_to_set, elem_of_app; left; left.
  - by eapply message_dependencies_are_sufficient.
Qed.

Lemma equivocating_messages_dependencies_are_directly_observed_or_equivocator_emitted
  s im
  (Him : can_emit (free_composite_vlsm IM) im)
  (Hnobserved : ¬ composite_has_been_directly_observed IM s im)
  : forall dm, msg_dep_happens_before message_dependencies dm im ->
    composite_has_been_directly_observed IM s dm \/
    exists v_i, v_i ∈ msg_dep_message_equivocators IM full_message_dependencies sender s im (Cv := Cv) /\
      can_emit (pre_loaded_with_all_messages_vlsm (IM (A v_i))) dm.
Proof.
  intros dm Hdm.
  destruct (decide (composite_has_been_directly_observed IM s dm)) as [Hobs | Hnobs]
  ; [by left | right].
  cut (exists v, sender dm = Some v /\
                 can_emit (pre_loaded_with_all_messages_vlsm (IM (A v))) dm).
  {
    intros (v & Hsender & Hemit).
    exists v; split; [| done].
    unfold msg_dep_message_equivocators, coeqv_message_equivocators,
      msg_dep_coequivocating_senders, not_directly_observed_happens_before_dependencies.
    rewrite decide_False, elem_of_list_to_set, elem_of_app, elem_of_elements,
      elem_of_list_to_set, !elem_of_map_option by done.
    right; exists dm.
    rewrite elem_of_elements, elem_of_filter.
    by setoid_rewrite full_message_dependencies_happens_before.
  }
  apply emitted_messages_are_valid in Him.
  by eapply msg_dep_happens_before_composite_no_initial_valid_messages_emitted_by_sender.
Qed.

Lemma message_equivocators_can_emit (s : vstate Limited) im
  (Hs : valid_state_prop
          (fixed_equivocation_vlsm_composition IM (Ci := Ci) (fin_sets.set_map A (state_annotation s)))
          (original_state s))
  (Hnobserved : ¬ composite_has_been_directly_observed IM (original_state s) im)
  (HLemit : can_emit (free_composite_vlsm IM) im)
  : can_emit
      (equivocators_composition_for_directly_observed IM (Ci := Ci)
        (fin_sets.set_map A (state_annotation s
            ∪ msg_dep_message_equivocators IM full_message_dependencies sender
                (original_state s) im))
        (original_state s))
      im.
Proof.
  eapply VLSM_embedding_can_emit.
  - unshelve apply equivocators_composition_for_directly_observed_index_incl_embedding with
      (indices1 := fin_sets.set_map A (msg_dep_message_equivocators IM (Cv := Cv)
        full_message_dependencies sender (original_state s) im)).
    intros x; rewrite !elem_of_elements.
    by apply set_map_mono, union_subseteq_r.
  - destruct (equivocating_messages_are_equivocator_emitted _ _ HLemit Hnobserved)
      as (j & Heqv_j & Hemitj).
    eapply sub_valid_preloaded_lifts_can_be_emitted;
      [by apply elem_of_elements, elem_of_map_2 | | done].
    cbn; intros dm H_dm.
    assert (Hdm : msg_dep_happens_before message_dependencies dm im)
        by (apply msg_dep_happens_before_iff_one; left; done).
    clear H_dm; revert dm Hdm.
    induction dm as [dm Hind] using
      (well_founded_ind (msg_dep_happens_before_wf message_dependencies full_message_dependencies _))
    ; intros Hdm.
    apply emitted_messages_are_valid_iff.
    destruct (equivocating_messages_dependencies_are_directly_observed_or_equivocator_emitted
      _ _ HLemit Hnobserved _ Hdm)
      as [Hobs_dm | (dm_i & Hdm_i & Hemit_dm)]
    ; [by left; right | right].
    eapply sub_valid_preloaded_lifts_can_be_emitted;
      [by apply elem_of_elements, elem_of_map_2 | | by eapply message_dependencies_are_sufficient].
    intros dm' Hdm'; apply Hind.
    + by apply msg_dep_happens_before_iff_one; left.
    + transitivity dm; [| done].
      by apply msg_dep_happens_before_iff_one; left.
Qed.

Lemma msg_dep_fixed_limited_equivocation_witnessed
  is tr
  (Htr : finite_valid_trace Limited is tr)
  (equivocators := state_annotation (finite_trace_last is tr))
  (Fixed := fixed_equivocation_vlsm_composition IM (Ci := Ci) (fin_sets.set_map A equivocators))
  : (sum_weights equivocators <= threshold)%R
      /\
    finite_valid_trace Fixed
      (original_state is)
      (pre_VLSM_embedding_finite_trace_project
        (type Limited) (composite_type IM) Datatypes.id original_state
        tr).
Proof.
  repeat split; [.. | by apply Htr].
  - by eapply coeqv_limited_equivocation_state_not_heavy,
            finite_valid_trace_last_pstate, Htr.
  - apply valid_trace_add_default_last in Htr.
    induction Htr using finite_valid_trace_init_to_rev_ind
    ; [constructor; apply initial_state_is_valid; apply Hsi |].
    setoid_rewrite map_app.
    apply finite_valid_trace_from_app_iff; split.
    + revert IHHtr.
      apply VLSM_incl_finite_valid_trace_from,
        fixed_equivocation_vlsm_composition_index_incl.
      intro; rewrite !elem_of_elements.
      apply set_map_mono; [done |].
      by eapply coeqv_limited_equivocation_transition_state_annotation_incl, Ht.
    + apply finite_valid_trace_singleton.
      unfold input_valid_transition, input_valid.
      change (map _ _) with (pre_VLSM_embedding_finite_trace_project (type Limited)
                              (composite_type IM) Datatypes.id original_state tr).
      rewrite <- pre_VLSM_embedding_finite_trace_last.
      assert (Hs : valid_state_prop
                    (fixed_equivocation_vlsm_composition IM (Ci := Ci) (fin_sets.set_map A (state_annotation s)))
                    (original_state s)).
      {
        replace s with (finite_trace_last si tr) at 2
             by (apply valid_trace_get_last in Htr; done).
        rewrite (pre_VLSM_embedding_finite_trace_last
                  (type Limited) (composite_type IM) Datatypes.id original_state si tr).
        by apply finite_valid_trace_last_pstate.
      }
      destruct Ht as [[HLs [HLim HLv]] HLt].
      cbn in HLt |- *; unfold annotated_transition in HLt; cbn in HLt.
      replace (finite_trace_last si _) with s
           by (apply valid_trace_get_last in Htr; congruence).
      destruct l as [i li], (vtransition _ _ _) as (si', om').
      inversion HLt; subst; clear HLt; cbn.
      repeat split.
      * revert Hs; apply VLSM_incl_valid_state.
        apply fixed_equivocation_vlsm_composition_index_incl.
        intro; rewrite !elem_of_elements.
        apply set_map_mono; [done |].
        by destruct iom as [im |]; [apply union_subseteq_l |].
      * destruct iom as [im |]
        ; [apply option_valid_message_Some | apply option_valid_message_None].
        destruct (decide (composite_has_been_directly_observed IM (original_state s) im))
              as [Hobs | Hnobs].
        -- eapply composite_directly_observed_valid; [| done].
           revert Hs; apply VLSM_incl_valid_state.
           apply fixed_equivocation_vlsm_composition_index_incl.
           intro; rewrite !elem_of_elements.
           by apply set_map_mono, union_subseteq_l.
        -- revert HLim.
           setoid_rewrite emitted_messages_are_valid_iff.
           intros [Hinit | Hemit]; [by left | right].
           eapply VLSM_weak_embedding_can_emit.
           {
             eapply EquivPreloadedBase_Fixed_weak_embedding
               with (base_s := original_state s).
             - revert Hs; apply VLSM_incl_valid_state.
               apply fixed_equivocation_vlsm_composition_index_incl.
               intro; rewrite !elem_of_elements.
               by apply set_map_mono, union_subseteq_l.
             - by intros; apply no_initial_messages_in_IM.
           }
           eapply VLSM_incl_can_emit.
           {
             apply Equivocators_Fixed_Strong_incl.
             revert Hs; apply VLSM_incl_valid_state.
             apply fixed_equivocation_vlsm_composition_index_incl.
             intro; rewrite !elem_of_elements.
             by apply set_map_mono, union_subseteq_l.
           }
           apply message_equivocators_can_emit; [done | done |].
           eapply VLSM_embedding_can_emit; [| done].
           by apply forget_annotations_projection.
      * by apply HLv.
      * destruct iom as [im |]; [| done].
        destruct (decide (composite_has_been_directly_observed IM (original_state s) im))
              as [Hobs | Hnobs]; [by left | right; cbn].
        apply message_equivocators_can_emit; [done | done |].
        apply emitted_messages_are_valid_iff in HLim
          as [[j [[mj Hmj] Heqim]] | Hemit]
        ; [clear Heqim; contradict Hmj; apply no_initial_messages_in_IM |].
        eapply VLSM_embedding_can_emit; [| done].
        by apply forget_annotations_projection.
Qed.

Corollary msg_dep_fixed_limited_equivocation is tr
  : finite_valid_trace Limited is tr ->
    fixed_limited_equivocation_prop IM threshold A
      (original_state is)
      (pre_VLSM_embedding_finite_trace_project
        (type Limited) (composite_type IM) Datatypes.id original_state
        tr) (Ci := Ci) (Cv := Cv).
Proof.
  intro Htr.
  exists (state_annotation (finite_trace_last is tr)).
  by apply msg_dep_fixed_limited_equivocation_witnessed.
Qed.

Lemma fixed_transition_preserves_annotation_equivocators
  (eqv_validators : Cv)
  (equivocators := fin_sets.set_map A eqv_validators : Ci)
  (is : vstate (free_composite_vlsm IM)) s tr
  (Htr1 :
    finite_valid_trace_init_to (fixed_equivocation_vlsm_composition IM equivocators)
    is s tr)
  l iom sf oom
  (Ht :
    input_valid_transition
      (fixed_equivocation_vlsm_composition IM equivocators) l
      (s, iom) (sf, oom))
  (Hsub_equivocators :
    state_annotation
      (@finite_trace_last _ (type Limited)
        {| original_state := is; state_annotation := `inhabitant |}
        (msg_dep_annotate_trace_with_equivocators IM full_message_dependencies sender is tr))
    ⊆ eqv_validators)
  : msg_dep_composite_transition_message_equivocators IM
      full_message_dependencies sender l
      (@finite_trace_last _ (type Limited)
        {| original_state := is; state_annotation := empty_set |}
        (annotate_trace_from (free_composite_vlsm IM)
          Cv
          (msg_dep_composite_transition_message_equivocators IM full_message_dependencies sender)
          {| original_state := is; state_annotation := empty_set |} tr), iom)
    ⊆ eqv_validators.
Proof.
  destruct iom as [im |]; [| done].
  apply ListFinSetExtras.set_union_subseteq_iff; split; [done | cbn].
  rewrite annotate_trace_from_last_original_state; cbn.
  replace (finite_trace_last _ _) with s
       by (apply valid_trace_get_last in Htr1; congruence).
  unfold coeqv_message_equivocators.
  case_decide as Hnobserved; [by apply empty_subseteq |].
  destruct Ht as [(Hs & Him & Hv & [Hobs | Hemitted]) Ht]
  ; [done | intros eqv Heqv].
  unfold msg_dep_coequivocating_senders,
         not_directly_observed_happens_before_dependencies in Heqv
  ; rewrite elem_of_list_to_set, elem_of_app,
      elem_of_elements, elem_of_list_to_set, !elem_of_map_option in Heqv
  ; setoid_rewrite elem_of_list_singleton in Heqv
  ; setoid_rewrite elem_of_elements in Heqv
  ; setoid_rewrite elem_of_filter in Heqv.
  destruct Heqv as [(msg & Hmsg & Hsender) | (msg & [Hnobserved_msg Hdep_msg] & Hsender)].
  - subst msg.
    eapply VLSM_incl_can_emit in Hemitted
    ; [| apply pre_loaded_vlsm_incl_pre_loaded_with_all_messages].
    apply can_emit_composite_project in Hemitted as [sub_eqv Hemitted].
    destruct_dec_sig sub_eqv _eqv H_eqv Heqsub_eqv; subst.
    unfold sub_IM in Hemitted; cbn in Hemitted.
    eapply Hsender_safety in Hemitted; [| done]; subst.
    apply elem_of_elements in H_eqv.
    by revert H_eqv; apply elem_of_set_map_inj.
  - cut (strong_fixed_equivocation IM equivocators s msg).
    {
      intros [Hobserved | Hemitted_msg].
      - contradict Hnobserved_msg.
        by eapply sent_by_non_equivocating_are_directly_observed.
      - eapply VLSM_incl_can_emit in Hemitted_msg
        ; [| apply pre_loaded_vlsm_incl_pre_loaded_with_all_messages].
        apply can_emit_composite_project in Hemitted_msg as [sub_i Hemitted_msg].
        destruct_dec_sig sub_i i Hi Heqsub_i; subst.
        eapply Hsender_safety in Hemitted_msg; [| done].
        cbn in Hemitted_msg; subst.
        apply elem_of_elements in Hi.
        by revert Hi; apply elem_of_set_map_inj.
    }
    eapply msg_dep_happens_before_reflect
    ; [| by apply full_message_dependencies_happens_before | right]
    ; cycle 1.
    + eapply VLSM_incl_can_emit; [| done].
      by apply Equivocators_Fixed_Strong_incl.
    + eapply msg_dep_rel_reflects_strong_fixed_equivocation
      ; [done | done |].
      apply VLSM_incl_valid_state; [| done].
      by apply Fixed_incl_StrongFixed.
Qed.

Lemma msg_dep_limited_fixed_equivocation
  (is : vstate (free_composite_vlsm IM)) (tr : list (composite_transition_item IM))
  : fixed_limited_equivocation_prop (Ci := Ci) (Cv := Cv) IM threshold A is tr ->
    finite_valid_trace Limited
      {| original_state := is; state_annotation := ` inhabitant |}
      (msg_dep_annotate_trace_with_equivocators IM full_message_dependencies sender is tr).
Proof.
  intros (equivocators & Hlimited & Htr).
  split; [| by split; [apply Htr |]].
  apply valid_trace_add_default_last in Htr.
  match goal with
  |- finite_valid_trace_from Limited ?is ?tr =>
    cut
      (finite_valid_trace_from Limited is tr /\
        (state_annotation (@finite_trace_last _ (type Limited) is tr) ⊆ equivocators))
  end
  ; [itauto |].
  induction Htr using finite_valid_trace_init_to_rev_strong_ind.
  - split; [| by apply empty_subseteq].
    by constructor; apply initial_state_is_valid.
  - rewrite @msg_dep_annotate_trace_with_equivocators_app; cbn.
    unfold annotate_trace_item; rewrite !finite_trace_last_is_last; cbn.
    split; cycle 1.
    + by eapply fixed_transition_preserves_annotation_equivocators
      ; [| | apply IHHtr1].
    + apply finite_valid_trace_from_app_iff.
      split; [by apply IHHtr1 |].
      apply finite_valid_trace_singleton.
      repeat split.
      * by apply finite_valid_trace_last_pstate, IHHtr1.
      * clear -Heqiom IHHtr2.
        destruct IHHtr2 as [IHHtr2 _].
        unfold empty_initial_message_or_final_output in Heqiom.
        destruct_list_last iom_tr iom_tr' iom_item Heqiom_tr
        ; [by apply option_initial_message_is_valid |].
        destruct iom as [im |]; [| apply option_valid_message_None].
        eapply valid_trace_output_is_valid; [done |].
        rewrite @msg_dep_annotate_trace_with_equivocators_app.
        apply Exists_app; right.
        destruct iom_item.
        by apply Exists_exists; eexists; split; [left |].
      * destruct l as [i li]; cbn.
        rewrite msg_dep_annotate_trace_with_equivocators_last_original_state; cbn.
        replace (finite_trace_last _ _) with s
             by (apply valid_trace_get_last in Htr1; congruence).
        by apply Ht.
      * apply Rle_trans with (sum_weights equivocators)
        ; [| done].
        apply sum_weights_subseteq.
        by eapply fixed_transition_preserves_annotation_equivocators; [.. | apply IHHtr1].
      * destruct l as [i li]; cbn; unfold annotated_transition; cbn.
        rewrite !msg_dep_annotate_trace_with_equivocators_last_original_state; cbn.
        replace (finite_trace_last _ _) with s
             by (apply valid_trace_get_last in Htr1; congruence).
        by destruct Ht as [_ Ht]; cbn in Ht
        ; destruct (vtransition _ _ _) as (si', om')
        ; inversion Ht.
Qed.

Lemma annotated_limited_incl_constrained_limited
  `{!finite.Finite validator}
  {is_equivocating_tracewise_no_has_been_sent_dec :
    RelDecision (is_equivocating_tracewise_no_has_been_sent IM A sender)}
  : VLSM_embedding
      Limited
      (tracewise_limited_equivocation_vlsm_composition IM threshold A sender (Cv := Cv))
      Datatypes.id original_state.
Proof.
  constructor; intros sX trX HtrX.
  eapply @traces_exhibiting_limited_equivocation_are_valid; [done.. | |].
  - by apply Hsender_safety.
  - by apply msg_dep_fixed_limited_equivocation.
Qed.

End sec_msg_dep_fixed_limited_equivocation.