(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
Require Import Coqlib.
Require Import Maps.
Require Import ASTExtra.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import Memory.
Require Import Events.
Require Import Stacklayout.
Require Import Globalenvs.
Require Import AsmX.
Require Import Smallstep.
Require Import AuxStateDataType.
Require Import Constant.
Require Import GlobIdent.
Require Import FlatMemory.
Require Import CommonTactic.
Require Import AuxLemma.
Require Import RealParams.
Require Import PrimSemantics.
Require Import LAsm.
Require Import XOmega.

Require Import compcert.cfrontend.Ctypes.
Require Import Conventions.
Require Import liblayers.logic.PTreeModules.
Require Import liblayers.logic.LayerLogicImpl.
Require Import liblayers.compat.CompatLayers.

Require Import AbstractDataType.
Require Import TSysCall.
Require Import I64Layer.
Require Import LoadStoreSem2.
Require Import MakeProgram.

Require Import SecurityCommon.
Require Import ProofIrrelevance.

(* This file proves that some new state invariants are preserved by each step
   of the tsyscall layer. Note that we do not specify whether these invariants hold
   on the initial state here, we only prove that they are preserved. The invariants are:
   1.) we are in host mode (this version of mCertiKOS does not support virtualization)
   2.) the return address pseudoregister RA in each process's saved register context
       always points to the code entry point of the proc_start_user primitive
   3.) the usermode predicate, which consists of three interdependent properties that
       essentially say that we are always in user mode. The only exceptions to being
       in user mode are when the special kernel process 0 is executing (initialization
       setup only), or when we just called yield and are about to re-enter user mode in
       a single step. The three properties are:
       a.) if we are in kernel mode, then the instruction pointer register must be
           pointing to the code entry point of the proc_start_user primitive
       b.) the currently-running process is not process 0
       c.) the ready queue is nonempty, and process 0 is never on the ready queue
   Paper Reference: Section 5 *)

Section WITHMEM.

  Local Open Scope Z_scope.

  Context `{real_params: RealParams}.

  Context `{Hstencil: Stencil}.
  Context `{Hmem: Mem.MemoryModel}.
  Context `{Hmwd: UseMemWithData mem}.

  Local Instance : ExternalCallsOps (mwd (cdata RData)) :=
    CompatExternalCalls.compatlayer_extcall_ops tsyscall_layer.
  Local Instance : LayerConfigurationOps := compatlayer_configuration_ops tsyscall_layer.

  Section IHOST_INV.

    Lemma exec_loadex_ihost_inv {F V} :
      forall ge chunk rs rs' (m m' : mem) (d d' : cdata RData) a rd,
        exec_loadex(F:=F)(V:=V) ge chunk (m,d) a rs rd = Next rs' (m',d') ->
        ihost d = true -> ihost d' = true.
    Proof.
      unfold exec_loadex, exec_loadex2; intros; subdestruct; rename H into Hexec.
      - unfold Asm.exec_load in Hexec; subdestruct; inv Hexec; auto.
      - unfold HostAccess2.exec_host_load2 in Hexec; subdestruct; inv Hexec; auto.
        unfold PageFault.exec_pagefault in *; subdestruct; inv H1; auto.
      - unfold Asm.exec_load in Hexec; subdestruct; inv Hexec; auto.
      - simpl in *; rewrites.
      - simpl in *; rewrites.
    Qed.

    Lemma exec_storeex_ihost_inv {F V} :
      forall ge chunk rs rs' (m m' : mem) (d d' : cdata RData) a rd rds,
        exec_storeex(F:=F)(V:=V) ge chunk (m,d) a rs rd rds = Next rs' (m',d') ->
        ihost d = true -> ihost d' = true.
    Proof.
      unfold exec_storeex, exec_storeex2; intros; subdestruct; rename H into Hexec.
      - unfold Asm.exec_store in Hexec; subdestruct; inv Hexec.
        unfold Mem.storev in *; unfold_lift; subdestruct; inv Hdestruct3; auto.
      - unfold HostAccess2.exec_host_store2 in Hexec; subdestruct.
        unfold FlatLoadStoreSem.exec_flatmem_store, flatmem_store in Hexec; subdestruct; inv Hexec; auto.
        unfold FlatLoadStoreSem.exec_flatmem_store, flatmem_store in Hexec; subdestruct; inv Hexec; auto.
        unfold PageFault.exec_pagefault in Hexec; subdestruct; inv Hexec; auto.
      - unfold Asm.exec_store in Hexec; subdestruct; inv Hexec.
        unfold Mem.storev in *; unfold_lift; subdestruct; inv Hdestruct3; auto.
      - simpl in *; rewrites.
      - simpl in *; rewrites.
    Qed.

    Lemma proc_start_user_host_inv:
      forall d d' rs,
        proc_start_user_spec d = Some (d', rs) ->
        ihost d' = true.
    Proof.
      unfold proc_start_user_spec. intros. subdestruct.
      inv H. trivial.
    Qed.

    Lemma ihost_inv :
      forall ge rs rs' (m m' : mem) (d d' : cdata RData) t,
        LAsm.step ge (State rs (m,d)) t (State rs' (m',d')) ->
        ihost d = true -> ihost d' = true.
    Proof.
      intros.
      eapply (step_P (fun d d' : cdata RData =>
                        ihost d = true -> ihost d' = true)) in H; eauto.
      - simpl; intros; eapply exec_loadex_ihost_inv; eauto.
      - simpl; intros; eapply exec_storeex_ihost_inv; eauto.
      - (* Case 2: EF_external *)
        intros. inv H1.
        destruct H3 as [σ [Hl [s [σ' [Hmatch [Hsem [? [? ?]]]]]]]]; subst.
        inv_layer Hl; inv Hsem; try assumption; gensem_simpl.
        (*+ functional inversion H3. trivial.*)
        + unfold proc_init_spec, ret in *; subdestruct; inv_somes; auto.
      - (* Case 3: prim_call step *)
        intros. destruct H1 as [x [sg [σ [Hef [Hl Hsem]]]]]; subst.
        inv_layer Hl; inv Hsem; simpl in *.
        {
          (* dispatch *)
          inv H4. inv H9.
          eapply proc_start_user_host_inv.
          eapply H4.
        }
        {
          (* pagefault *)
          inv H4. inv H10.
          eapply proc_start_user_host_inv.
          eapply H4.
        }
        {
          (* yield *)
          inv H4.
          inv_spec; inv_somes; auto.
        }
        {
          (* proc_start_user *)
          inv H4.
          eapply proc_start_user_host_inv; eauto.
        }
    Qed.

  End IHOST_INV.

  Ltac fun_inv_spec :=
    match goal with
      | H: _ = Some ?a |- context[?a] =>
        try (functional inversion H; clear H)
    end.

  Section WITHIMPL.

    Context `{make_program_ops: !MakeProgramOps function Ctypes.type fundef unit}.
    Context `{make_program_prf: !MakeProgram function Ctypes.type fundef unit}.

    Variables (b : block).

    Definition RA_startuser d :=
      forall id,
        id <> 0 -> cused (ZMap.get id (AC d)) = true ->
        ZMap.get id (kctxt d) RA = Vptr b Int.zero.

    Lemma exec_loadex_RA_startuser_inv :
      forall {F V} ge chunk rs rs' (m m' : mem) (d d' : cdata RData) a rd,
        exec_loadex (F:=F) (V:=V) ge chunk (m,d) a rs rd = Next rs' (m',d') ->
        ihost d = true -> RA_startuser d -> RA_startuser d'.
    Proof.
      unfold exec_loadex, exec_loadex2; intros; subdestruct; rename H into Hexec.
      - unfold Asm.exec_load in Hexec; subdestruct; inv Hexec; auto.
      - unfold HostAccess2.exec_host_load2 in Hexec; subdestruct; inv Hexec; auto.
        unfold PageFault.exec_pagefault in *; subdestruct; inv H2; auto.
      - unfold Asm.exec_load in Hexec; subdestruct; inv Hexec; auto.
      - simpl in *; rewrites.
      - simpl in *; rewrites.
    Qed.

    Lemma exec_storeex_RA_startuser_inv:
      forall {F V} ge chunk rs rs' (m m' : mem) (d d' : cdata RData) a rd rds,
        exec_storeex(F:=F)(V:=V) ge chunk (m,d) a rs rd rds = Next rs' (m',d') ->
        ihost d = true -> RA_startuser d -> RA_startuser d'.
    Proof.
      unfold exec_storeex, exec_storeex2; intros; subdestruct; rename H into Hexec.
      - unfold Asm.exec_store in Hexec; subdestruct; inv Hexec.
        unfold Mem.storev in *; unfold_lift; subdestruct; inv Hdestruct3; auto.
      - unfold HostAccess2.exec_host_store2 in Hexec; subdestruct.
        unfold FlatLoadStoreSem.exec_flatmem_store, flatmem_store in Hexec; subdestruct; inv Hexec; auto.
        unfold FlatLoadStoreSem.exec_flatmem_store, flatmem_store in Hexec; subdestruct; inv Hexec; auto.
        unfold PageFault.exec_pagefault in Hexec; subdestruct; inv Hexec; auto.
      - unfold Asm.exec_store in Hexec; subdestruct; inv Hexec.
        unfold Mem.storev in *; unfold_lift; subdestruct; inv Hdestruct3; auto.
      - simpl in *; rewrites.
      - simpl in *; rewrites.
    Qed.

    Variables (s : stencil) (M : module) (ge : genv).

    Hypothesis (Hmake : make_globalenv s M tsyscall_layer = OK ge).
    Hypothesis (Hpsu : Genv.find_symbol ge proc_start_user = Some b).

    (* needed so that the inv_spec tactic doesn't interpret find_symbol as a spec *)
    Opaque Genv.find_symbol find_symbol.

    Let local_stencil_matches : stencil_matches s ge.
    Proof.
      eapply make_globalenv_stencil_matches; eauto.
    Qed.

    Let local_find_symbol : find_symbol s proc_start_user = Some b.
    Proof.
      erewrite <- stencil_matches_symbols; eauto.
    Qed.

    Section YIELD_RA_INV.

      Lemma trap_into_kernel_RA_startuser_inv :
      forall id s' m' rs d d' vargs sg0 b0 v0
             v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11 v12 v13 v14 v15 v16,
        trap_into_kernel_spec id s' m' rs d d' vargs sg0 b0 v0
          v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11 v12 v13 v14 v15 v16 ->
        RA_startuser d -> RA_startuser d'.
      Proof.
        intros until v16; intro Hspec; inv Hspec.
        decompose [and] H0; inv_spec; inv_somes; auto.
      Qed.

      Lemma ptInsertPTE0_RA_startuser_inv:
        forall i vadr padr pm d d',
          ptInsertPTE0_spec i vadr padr pm d = Some d' ->
          RA_startuser d -> RA_startuser d'.
      Proof.
        intros; inv_spec; inv_somes; simpl; auto.
      Qed.

      Lemma ptAllocPDE0_RA_startuser_inv:
        forall i1 i2 n d d',
          ptAllocPDE0_spec i1 i2 d = Some (d', n) ->
          RA_startuser d -> RA_startuser d'.
      Proof.
        intros. functional inversion H; subst; auto; simpl;clear H.
        unfold RA_startuser in *; simpl in *. intros.
        destruct (zeq id i1); subst.
        - rewrite ZMap.gss in H1. subst cur c. simpl in *.
          eapply H0; eauto.
        - rewrite ZMap.gso in H1; eauto.
      Qed.

      Lemma ptInsert0_RA_startuser_inv:
        forall i1 i2 b i3 d d' v,
          ptInsert0_spec i1 i2 b i3 d = Some (d', v) ->
          RA_startuser d -> RA_startuser d'.
      Proof.
        intros; inv_spec; inv_somes; clear Hdestruct4.
        - eapply ptInsertPTE0_RA_startuser_inv; eauto.
        - eapply ptAllocPDE0_RA_startuser_inv; eauto.
        - eapply ptInsertPTE0_RA_startuser_inv; eauto.
          eapply ptAllocPDE0_RA_startuser_inv; eauto.
      Qed.

      Lemma palloc_RA_startuser_inv:
        forall i r d d',
          alloc_spec i d = Some (d', r) ->
          RA_startuser d -> RA_startuser d'.
      Proof.
        intros; inv_spec; inv_somes; auto; simpl.
        unfold RA_startuser in *; simpl in *. intros.
        destruct (zeq id i); subst.
        - rewrite ZMap.gss in H1. simpl in *.
          eapply H0; eauto.
        - rewrite ZMap.gso in H1; eauto.
      Qed.

      Lemma ptResv2_RA_startuser_inv :
        forall i2 i3 i5 i6 n d d',
          ptResv2_spec 1 i2 i3 2 i5 i6 d = Some (d', n) ->
          RA_startuser d -> RA_startuser d'.
      Proof.
        intros. functional inversion H; subst; clear H; trivial.
        - eapply ptInsert0_RA_startuser_inv; eauto.
          eapply palloc_RA_startuser_inv; eauto.
        - eapply ptInsert0_RA_startuser_inv; eauto.
          eapply ptInsert0_RA_startuser_inv; eauto.
          eapply palloc_RA_startuser_inv; eauto.
      Qed.

      Lemma sys_dispatch_RA_startuser_inv :
        forall s m d d',
          stencil_matches s ge ->
          sys_dispatch_c_spec s m d = Some d' ->
          RA_startuser d -> RA_startuser d'.
      Proof.
        intros; inv_spec; fun_inv_spec;
        inv_somes; auto.
        - repeat inv_spec;
          inv_somes; simpl in *; auto;
          unfold RA_startuser in *; simpl in *.
          intros id Hn0 Hused; zmap_solve.
          + rewrite Pregmap.gss.
            rewrite (stencil_matches_unique _ _ _ H local_stencil_matches) in Hdestruct14.
            rewrites; reflexivity.
          + unfold update_cchildren, update_cusage in Hused; simpl in Hused.
            zmap_solve; subst; auto.

        - repeat inv_spec;
          inv_somes; simpl in *; auto.
        - unfold RA_startuser in *.
          functional inversion H2; subst. clear H2.
          subst uctx uctx'. simpl.
          functional inversion H7; subst; simpl in *. clear H7.
          subst uctx uctx'.
          functional inversion H6; subst; simpl in *; auto; clear H6.
          eapply ptResv2_RA_startuser_inv; eauto.
          eapply ptResv2_RA_startuser_inv; eauto.
        - repeat inv_spec;
          inv_somes; simpl in *; auto.
        - repeat inv_spec;
          inv_somes; simpl in *; auto.
      Qed.

      Lemma ptfault_resv_RA_startuser_inv :
        forall v d d',
          ptfault_resv_spec v d = Some d' ->
          RA_startuser d -> RA_startuser d'.
      Proof.
        intros v d d' Hspec.
        inv_spec; inv_somes; auto.
        inv_spec; inv_somes; simpl; eauto.
        intros.
        unfold RA_startuser in *; simpl in *.
        eapply ptInsert0_RA_startuser_inv; eauto.
        eapply palloc_RA_startuser_inv; eauto.
      Qed.

      Lemma proc_start_user_RA_startuser_inv :
        forall rs d d',
          proc_start_user_spec d = Some (d', rs) ->
          RA_startuser d -> RA_startuser d'.
      Proof.
        intros; inv_spec; inv_somes; auto.
      Qed.

      Ltac solve_RA_startuser_inv :=
        repeat match goal with
        | [ H : appcontext [syscall_spec] |- _ ] => inv H
        | [ H : proc_start_user_spec _ = _ /\ _ |- _ ] => destruct H
        | [ H : appcontext [trap_into_kernel_spec _ _ _ _ _ ?d] |- RA_startuser ?d ] =>
          eapply trap_into_kernel_RA_startuser_inv; eauto
        | [ H : appcontext [proc_start_user_spec _ = Some (?d,_)] |- RA_startuser ?d ] =>
          eapply proc_start_user_RA_startuser_inv; eauto
        | [ H : appcontext [sys_dispatch_c_spec _ _ _ = Some ?d] |- RA_startuser ?d ] =>
          eapply sys_dispatch_RA_startuser_inv; eauto
        | [ H : appcontext [ptfault_resv_spec _ _ = Some ?d] |- RA_startuser ?d ] =>
          eapply ptfault_resv_RA_startuser_inv; eauto
        end.

      Lemma RA_startuser_inv :
        forall rs rs' (m m' : mem) (d d' : cdata RData) t,
          LAsm.step ge (State rs (m,d)) t (State rs' (m',d')) ->
          ihost d = true -> RA_startuser d -> RA_startuser d'.
      Proof.
        intros.
        eapply (step_P (fun d d' : cdata RData =>
                          ihost d = true -> RA_startuser d -> RA_startuser d')) in H; eauto.
        - simpl; intros; eapply exec_loadex_RA_startuser_inv; eauto.
        - simpl; intros; eapply exec_storeex_RA_startuser_inv; eauto.
        - (* Case 2: EF_external *)
          intros. inv H2.
          destruct H5 as [σ [Hl [s' [σ' [Hmatch [Hsem [? [? ?]]]]]]]]; subst.
          inv_layer Hl; inv Hsem; try assumption; gensem_simpl.
          (*+ functional inversion H5. trivial.*)
          + unfold proc_init_spec, ret in *; subdestruct; inv_somes.
            unfold RA_startuser; simpl; intros id Hn0 Hused.
            unfold real_AC in Hused; zmap_solve; inv Hused.
        - (* Case 3: prim_call step *)
          intros. destruct H2 as [x [sg [σ [Hef [Hl Hsem]]]]]; subst.
          inv_layer Hl; inv Hsem; simpl in *; inv H6; solve_RA_startuser_inv.
          unfold thread_yield_spec in *; subdestruct; inv_somes; unfold RA_startuser; simpl; intros; zmap_solve.
          {
            rewrite Pregmap.gss; f_equal.
            assert (Heq:= stencil_matches_unique _ _ _ local_stencil_matches H5); congruence.
          }
          {
            eapply trap_into_kernel_RA_startuser_inv in H6; eauto.
          }
          {
            rewrite Pregmap.gss; f_equal.
            assert (Heq:= stencil_matches_unique _ _ _ local_stencil_matches H5); congruence.
          }
          {
            eapply trap_into_kernel_RA_startuser_inv in H6; eauto.
          }
      Qed.

    End YIELD_RA_INV.

    Section USERMODE_INV.

      Notation abq_inv d := (forall l,
                              ZMap.get num_id (abq d) = AbQValid l ->
                              l <> nil /\ forall id, In id l -> 0 < id).

      Record usermode (rs : regset) (d : cdata RData) :=
        {
          usermode_ikern: ikern d = true -> rs PC = Vptr b Int.zero;
          usermode_cid: 0 < cid d;
          usermode_abq: abq_inv d
        }.

      Lemma startuser_step :
        forall rs rs' (m m' : mem) (d d' : cdata RData) t,
          LAsm.step ge (State rs (m,d)) t (State rs' (m',d')) ->
          rs PC = Vptr b Int.zero ->
          primcall_startuser_sem proc_start_user_spec s rs (m,d) rs' (m',d') /\ t = E0.
      Proof.
        intros rs rs' m m' d d' t Hstep Hpc.
        assert (Hmake': make_globalenv s M tsyscall_layer = ret ge) by auto.
        clear Hmake; rename Hmake' into Hmake; unfold tsyscall_layer in Hmake; inv_make_globalenv Hmake.
        unfold tsyscall, tsyscall_passthrough in HLge0; inv_make_globalenv HLge0.
        assert (b1 = b).
        {
          inv HLge0le.
          specialize (genv_le_find_symbol proc_start_user).
          rewrite Hb1fs, Hpsu in genv_le_find_symbol; inv genv_le_find_symbol; auto.
        }
        subst.
        assert (Genv.find_funct_ptr ge b = Some (External (EF_external proc_start_user null_signature))).
        {
          inv HLge0le.
          specialize (genv_le_find_funct_ptr b).
          rewrite Hb1fp in genv_le_find_funct_ptr; inv genv_le_find_funct_ptr; auto.
        }
        assert (Heq: get_layer_primitive proc_start_user tsyscall_layer
                     = OK (Some (primcall_start_user_compatsem proc_start_user_spec))) by reflexivity.
        rename H into Hbfp; inv Hstep; rewrites.
        - inv H7.
          inv H.
          destruct H0 as [Hl Hsem].
          inv Hsem.
          destruct H as [σ' [Hmatch' [Hsem [Hcon _]]]]; subst.
          unfold ident in *.
          rewrite Heq in Hl. inv Hl.
        - inv H6.
          destruct H as [sg [σ [Hext [Hl Hsem]]]]; inv Hext.
          unfold ident in *.
          rewrite Heq in Hl. inv Hl.
          inv Hsem; simpl in *.
          rewrite (stencil_matches_unique _ _ _ local_stencil_matches H0); auto.
      Qed.

      Lemma startuser_step_d :
        forall rs rs' (m m' : mem) (d d' : cdata RData) t,
          LAsm.step ge (State rs (m,d)) t (State rs' (m',d')) ->
          rs PC = Vptr b Int.zero ->
          d' = d {ikern: false} {ipt: false} {PT: cid d}.
      Proof.
        intros rs rs' m m' d d' t Hstep Hpc.
        destruct (startuser_step _ _ _ _ _ _ _ Hstep Hpc) as [Hsem ?]; inv Hsem.
        inv_spec; inv_rewrite.
      Qed.

      Lemma exec_loadex_usermode_inv :
        forall chunk rs rs' (m m' : mem) (d d' : cdata RData) a rd,
          exec_loadex ge chunk (m,d) a rs rd = Next rs' (m',d') ->
          ikern d = false -> ihost d = true -> usermode rs d -> usermode rs' d'.
      Proof.
        unfold exec_loadex, exec_loadex2; intros; subdestruct; rename H into Hexec.
        - destruct H2.
          unfold HostAccess2.exec_host_load2 in Hexec; subdestruct;
            try solve [inv Hexec; constructor; intros; rewrites; eauto].
          unfold PageFault.exec_pagefault in *; subdestruct; inv Hexec.
          constructor; simpl; auto; intros; rewrites.
        - simpl in *; rewrites.
      Qed.

      Lemma exec_storeex_usermode_inv :
        forall chunk rs rs' (m m' : mem) (d d' : cdata RData) a rd rds,
          exec_storeex ge chunk (m,d) a rs rd rds = Next rs' (m',d') ->
          ikern d = false -> ihost d = true -> usermode rs d -> usermode rs' d'.
      Proof.
        unfold exec_storeex, exec_storeex2; intros; subdestruct; rename H into Hexec.
        - destruct H2.
          unfold HostAccess2.exec_host_store2 in Hexec; subdestruct;
            try solve [unfold FlatLoadStoreSem.exec_flatmem_store, flatmem_store in Hexec;
                       subdestruct; inv Hexec; constructor; simpl; eauto; intros; rewrites].
          unfold PageFault.exec_pagefault in Hexec; subdestruct; inv Hexec.
          constructor; simpl; auto; intros; rewrites.
        - simpl in *; rewrites.
      Qed.

      Lemma trap_into_kernel_usermode_cid :
        forall id s' m' rs d d' vargs sg0 b0 v0
             v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11 v12 v13 v14 v15 v16,
          trap_into_kernel_spec id s' m' rs d d' vargs sg0 b0 v0
            v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11 v12 v13 v14 v15 v16 ->
          cid d = cid d'.
      Proof.
        intros until v16; intro Hspec; inv Hspec.
        decompose [and] H0; inv_spec; inv_somes; auto.
      Qed.

      Lemma trap_into_kernel_usermode_abq :
        forall id s' m' rs d d' vargs sg0 b0 v0
             v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11 v12 v13 v14 v15 v16,
          trap_into_kernel_spec id s' m' rs d d' vargs sg0 b0 v0
            v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11 v12 v13 v14 v15 v16 ->
          abq d = abq d'.
      Proof.
        intros until v16; intro Hspec; inv Hspec.
        decompose [and] H0; inv_spec; inv_somes; auto.
      Qed.

      Lemma ptInsertPTE0_cid:
        forall i1 vadr padr pm d d',
          ptInsertPTE0_spec i1 vadr padr pm d = Some d' ->
          cid d = cid d'
          /\ (0 < cid d -> abq_inv d -> abq_inv d').
      Proof.
        intros; inv_spec; inv_somes; simpl; auto.
      Qed.

      Lemma ptAllocPDE0_cid:
        forall i1 i2 n d d',
          ptAllocPDE0_spec i1 i2 d = Some (d', n) ->
          cid d = cid d'
          /\ (0 < cid d -> abq_inv d -> abq_inv d').
      Proof.
        intros. functional inversion H; subst; auto; simpl;clear H.
      Qed.

      Definition Q d d' :=
        cid d = cid d'
        /\ (0 < cid d -> abq_inv d -> abq_inv d').

      Lemma Q_trans:
        forall d1 d2 d3,
          Q d1 d2 ->
          Q d2 d3 ->
          Q d1 d3.
      Proof.
        unfold Q. intros d1 d2 d3.
        intros (He & Hi) (He' & Hi').
        split. congruence.
        intros Hle Habq.
        eapply Hi'. rewrite <- He; trivial.
        eapply Hi; assumption.
      Qed.

      Lemma ptInsert0_cid:
        forall i1 i2 b i3 d d' v,
          ptInsert0_spec i1 i2 b i3 d = Some (d', v) ->
          cid d = cid d'
          /\ (0 < cid d -> abq_inv d -> abq_inv d').
      Proof.
        intros; inv_spec; inv_somes; clear Hdestruct4.
        - eapply ptInsertPTE0_cid; eauto.
        - eapply ptAllocPDE0_cid; eauto.
        - exploit ptInsertPTE0_cid; eauto.
          exploit ptAllocPDE0_cid; eauto. intros.
          eapply Q_trans; eauto.
      Qed.

      Lemma alloc_cid:
        forall i1 d d' b,
          alloc_spec i1 d = Some (d', b) ->
          Q d d'.
      Proof.
        intros. unfold Q.
        functional inversion H; auto.
      Qed.

      Lemma ptResv2_cid :
        forall i1 i4 i2 i3 i5 i6 n d d',
          ptResv2_spec i1 i2 i3 i4 i5 i6 d = Some (d', n) ->
          cid d = cid d'
          /\ (0 < cid d -> abq_inv d -> abq_inv d').
      Proof.
        intros. functional inversion H; subst; clear H.
        - auto.
        - exploit ptInsert0_cid; eauto; intros.
          eapply Q_trans; eauto.
          eapply alloc_cid; eauto.
        - exploit ptInsert0_cid; eauto; intros.
          eapply Q_trans; eauto.
          clear H0.
          exploit ptInsert0_cid; eauto; intros.
          eapply Q_trans; eauto.
          eapply alloc_cid; eauto.
      Qed.

      Lemma sys_dispatch_usermode :
        forall s m d d',
          sys_dispatch_c_spec s m d = Some d' ->
          cid d = cid d'
          /\ (0 < cid d -> abq_inv d -> abq_inv d').
      Proof.
        intros; inv_spec; fun_inv_spec;
        inv_somes; auto.
        - repeat inv_spec;
          inv_somes; simpl in *; auto.
          rewrite ZMap.gss. split; trivial.
          intros. destruct (H0 l1); inv H1; auto. split; [discriminate|].
          intro id; specialize (H3 id); simpl; intuition.
        - repeat inv_spec;
          inv_somes; simpl in *; auto.

        - functional inversion H0; subst. clear H0.
          subst uctx uctx'. simpl.
          functional inversion H5; subst; simpl in *. clear H5.
          subst uctx uctx'.
          functional inversion H4; subst; simpl in *; auto; clear H4.
          eapply ptResv2_cid; eauto.
          eapply ptResv2_cid; eauto.

        - repeat inv_spec;
          inv_somes; simpl in *; auto.
        - repeat inv_spec;
          inv_somes; simpl in *; auto.
      Qed.

      Lemma ptfault_resv_usermode:
        forall v d d',
          ptfault_resv_spec v d = Some d' ->
          Q d d'.
      Proof.
        intros v d d' Hspec.
        inv_spec; inv_somes.
        inv_spec; inv_somes; simpl; auto; unfold Q; simpl; eauto.
        exploit alloc_cid; eauto. intros.
        eapply Q_trans; eauto.
        eapply ptInsert0_cid; eauto.
        unfold Q; auto.
      Qed.

      Lemma thread_yield_usermode_ikern :
        forall rs rs' d d',
          thread_yield_spec d rs = Some (d', rs') ->
          high_level_invariant d -> RA_startuser d -> abq_inv d ->
          rs' RA = Vptr b Int.zero.
      Proof.
        unfold RA_startuser; intros rs rs' d d' Hspec Hinv Hra Habq.
        repeat inv_spec; inv_somes; simpl.
        assert (Hin: In (last l num_id) l) by (apply last_correct; auto); apply Hra.
        assert (0 < last l 64) by (eapply Habq; eauto); omega.
        destruct (cused (ZMap.get (last l num_id) (AC d))) eqn:Hused; auto.
        assert (0 <= last l num_id < num_id).
        {
          destruct (valid_TDQ _ Hinv Hdestruct num_id) as [l' [? Hrange]]; try omega.
          apply Hrange; rewrites; auto.
        }
        eapply (valid_inQ _ Hinv) in Hdestruct3; eauto; try omega.
        destruct (Hdestruct3 Hin) as [st Htcb].
        apply (valid_notinQ _ Hinv) in Htcb; auto; try omega.
      Qed.

      Lemma thread_yield_usermode_cid :
        forall rs rs' d d',
          thread_yield_spec d rs = Some (d', rs') ->
          abq_inv d -> 0 < cid d'.
      Proof.
        intros; repeat inv_spec; inv_somes; simpl.
        apply (H0 l); auto.
        apply last_correct; auto.
      Qed.

      Lemma thread_yield_usermode_abq :
        forall rs rs' d d',
          high_level_invariant d ->
          thread_yield_spec d rs = Some (d', rs') ->
          0 < cid d -> abq_inv d -> abq_inv d'.
      Proof.
        intros rs rs' d d' Hinv; intros; repeat inv_spec; inv_somes; simpl in *.
        zmap_simpl; inv H2.
        destruct (zeq (last l0 num_id) (cid d)).
        - (* show by contradiction that cid cannot be in the ready queue *)
          edestruct (valid_inQ _ Hinv); eauto; try omega.
          eapply valid_curid; eauto.
          rewrite <- e; apply last_correct; auto.
          edestruct (valid_TCB _ Hinv) as [? [? [? [? _]]]]; eauto.
          eapply valid_curid; eauto.
          edestruct (correct_curid _ Hinv); eauto; rewrites.
        - split; [discriminate|].
          destruct (H1 l0); subst; auto.
          simpl; intros ? [?|?]; try congruence.
          eapply INVLemmaThread.remove_property; eauto.
      Qed.

      Lemma proc_start_user_usermode_ikern :
        forall rs d d',
          proc_start_user_spec d = Some (d', rs) ->
          ikern d' = false.
      Proof.
        intros; inv_spec; inv_somes; auto.
      Qed.

      Lemma proc_start_user_usermode_cid :
        forall rs d d',
          proc_start_user_spec d = Some (d', rs) ->
          cid d = cid d'.
      Proof.
        intros; inv_spec; inv_somes; auto.
      Qed.

      Lemma proc_start_user_usermode_abq :
        forall rs d d',
          proc_start_user_spec d = Some (d', rs) ->
          abq d = abq d'.
      Proof.
        intros; inv_spec; inv_somes; auto.
      Qed.

      Ltac solve_usermode_inv :=
        repeat match goal with
        | [ H : appcontext [syscall_spec] |- _ ] => inv H
        | [ H : proc_start_user_spec _ = _ /\ _ |- _ ] => destruct H
(*
        | [ H : appcontext [trap_into_kernel_spec] |- _ ] =>
          apply trap_into_kernel_usermode_inv in H
        | [ H : appcontext [proc_start_user_spec] |- _ ] =>
          apply proc_start_user_usermode_inv in H
        | [ H : appcontext [sys_dispatch_c_spec] |- _ ] =>
          apply sys_dispatch_usermode_inv in H
        | [ H : appcontext [ptfault_resv_spec] |- _ ] =>
          apply ptfault_resv_usermode_inv in H     *)
        end(*; try congruence*).

      Ltac sapply H :=
        match goal with
          | [H' : _ |- _] => apply H in H'
        end.

      Ltac seapply H :=
        match goal with
          | [H' : _ |- _] => eapply H in H'
        end.

      Lemma abq_inv_trans:
        forall d d',
          abq_inv d ->
          abq d = abq d' ->
          abq_inv d'.
      Proof.
        intros. rewrite <- H0 in H1.
        exploit H; eauto.
      Qed.

      Lemma usermode_inv :
        forall rs rs' (m m' : mem) (d d' : cdata RData) t,
          LAsm.step ge (State rs (m,d)) t (State rs' (m',d')) ->
          high_level_invariant d -> ihost d = true -> RA_startuser d ->
          usermode rs d -> usermode rs' d'.
      Proof.
        intros rs rs' m m' d d' t Hstep Hinv Hhost Hra Huser.
        destruct (ikern d) eqn:Hkern.
        destruct Huser; erewrite startuser_step_d; eauto.
        constructor; auto; discriminate.
        inv Hstep; try solve [simpl in *; destruct EXT_ALLOWED; rewrites].
        {
          (* Case 1: internal step (assembly command) *)
          rename H7 into Hexec.
          destruct Huser; destruct i; simpl in *;
          try solve [inv Hexec; constructor; auto; rewrite Hkern; discriminate |
                     eapply exec_loadex_usermode_inv; eauto; constructor; auto |
                     eapply exec_storeex_usermode_inv; eauto; constructor; auto].
          destruct i; simpl in *;
          try solve [inv Hexec; constructor; auto; rewrite Hkern; discriminate |
                     eapply exec_loadex_usermode_inv; eauto; constructor; auto |
                     eapply exec_storeex_usermode_inv; eauto; constructor; auto |
                     unfold goto_label in *; subdestruct; inv Hexec;
                       constructor; auto; rewrite Hkern; discriminate |
                     unfold lift in *; simpl in *; subdestruct; inv Hexec;
                       constructor; auto; rewrite Hkern; discriminate].
        }
        {
          (* Case 2: prim_call step *)
          destruct H6 as [x [sg [σ [Hef [Hl Hsem]]]]]; subst.
          inv_layer Hl; inv Hsem; simpl in *; inv H1; solve_usermode_inv.
          - (* dispatch *)
            destruct Huser; constructor.
            + sapply proc_start_user_usermode_ikern; congruence.
            + sapply trap_into_kernel_usermode_cid.
              sapply proc_start_user_usermode_cid.
              sapply sys_dispatch_usermode. destruct H10 as (HP & _ ). congruence.
            + assert (0 < cid labd0) by (sapply trap_into_kernel_usermode_cid; congruence).
              sapply trap_into_kernel_usermode_abq.
              sapply proc_start_user_usermode_abq.
              sapply sys_dispatch_usermode; destruct H10 as [? Habq].
              rewrite <- H1; apply Habq; auto.
              rewrite <- H; auto.
          - (* pagefault *)
            destruct Huser; constructor.
            + sapply proc_start_user_usermode_ikern; congruence.
            + sapply trap_into_kernel_usermode_cid.
              sapply proc_start_user_usermode_cid.
              sapply ptfault_resv_usermode. destruct H11 as (HP & _). congruence.
            + exploit trap_into_kernel_usermode_cid; eauto. intros Heq.
              sapply trap_into_kernel_usermode_abq.
              sapply proc_start_user_usermode_abq.
              sapply ptfault_resv_usermode. destruct H11 as (HP1 & HP2).
              eapply abq_inv_trans; [|eassumption].
              eapply HP2; eauto.
              {
                rewrite <- Heq. trivial.
              }
              eapply abq_inv_trans; eauto.

          - (* yield *)
            destruct Huser; constructor.
            + rewrite Pregmap.gss.
              intro; eapply thread_yield_usermode_ikern; eauto.
              eapply trap_into_kernel_high_inv; eauto.
              eapply trap_into_kernel_RA_startuser_inv; eauto.
              sapply trap_into_kernel_usermode_abq.
              intros l'; intros; apply (usermode_abq0 l'); congruence.
            + eapply thread_yield_usermode_cid; eauto.
              sapply trap_into_kernel_usermode_abq.
              intros l'; intros; apply (usermode_abq0 l'); congruence.
            + eapply thread_yield_usermode_abq; [|eauto|..].
              eapply trap_into_kernel_high_inv; eauto.
              sapply trap_into_kernel_usermode_cid; congruence.
              sapply trap_into_kernel_usermode_abq.
              intros l'; intros; apply (usermode_abq0 l'); congruence.
          - (* proc_start_user *)
            destruct Huser; constructor.
            + sapply proc_start_user_usermode_ikern; congruence.
            + sapply proc_start_user_usermode_cid; congruence.
            + sapply proc_start_user_usermode_abq.
              intros l'; intros; apply (usermode_abq0 l'); congruence.
        }
      Qed.

    End USERMODE_INV.

  End WITHIMPL.

End WITHMEM.


Require Import Term ConcreteEvidence StMonad_Coq.

Require Import Example_Phrases_Demo.

Require Import Appraisal_Defs Appraisal_IO_Stubs AM_Monad AM_St.

Require Import IO_Stubs privPolicy Cvm_Run.

Require Import List.
Import ListNotations.

Definition peel_bs_am (ls:RawEv) : AM (BS * RawEv) :=
  match ls with
  | bs :: ls' => ret (bs, ls')
  | _ => failm
  end.

Fixpoint gen_appraise_AM (et:Evidence) (ls:RawEv) : AM AppResultC :=
  match et with
  | mt => ret mtc_app
  | nn nid =>
    v <- (peel_bs_am ls) ;;
    match v with
      (bs, _) =>
      res <- checkNonce' nid bs ;;
      ret (nnc_app nid res)
    end

  | uu p fwd params et' =>
    match fwd with
    | COMP => ret mtc_app (* TODO hash check *)
    | ENCR =>
      v <- peel_bs_am ls ;;
      match v with
        (bs, ls') =>
        decrypted_ls <- decrypt_bs_to_rawev' bs params ;;
        rest <- gen_appraise_AM et' decrypted_ls ;;
        ret (eec_app p params passed_bs rest)
      (* TODO: consider encoding success/failure  of decryption for bs param
         (instead of default_bs)  *)
      end

    | EXTD =>
      v <- peel_bs_am ls ;;
      match v with
        (bs, ls') =>
        v <- check_asp_EXTD' params p bs ls' ;;
        rest <- gen_appraise_AM et' ls' ;;
        ret (ggc_app p params v rest)
      end
    | KILL => ret mtc_app (* Do we ever reach this case? *)
    | KEEP => gen_appraise_AM et' ls (* Do we ever reach this case? *)
    end
  | ss et1 et2 =>
      x <- gen_appraise_AM et1 (firstn (et_size et1) ls) ;;
      y <- gen_appraise_AM et2 (skipn (et_size et1) ls) ;;
      ret (ssc_app x y)
    end.

(*
Definition gen_appraise_am_comp (t:Term) (p:Plc) (et:Evidence) (ls:RawEv) : AM AppResultC :=
  gen_appraise_AM (eval t p et) ls.
*)

(*
Definition run_gen_appraise_am (t:Term) (p:Plc) (et:Evidence) (ls:RawEv) : AppResultC :=
  let am_appr_comp := gen_appraise_AM (eval t p et) ls in
  (run_am_app_comp am_appr_comp mtc_app).
*)

(*

Definition checkASP (i:ASP_ID) (args:list Arg) (tpl:Plc) (tid:Plc) (bs:BS) : BS.
Admitted.

Definition checkSig (ls:EvBits) (p:Plc) (sig:BS) : BS.
Admitted.

Definition checkHash (e:Evidence) (p:Plc) (hash:BS) : BS.
Admitted.

Definition peel_bs (ls:EvBits) : option (BS * EvBits) :=
  match ls with
  | bs :: ls' => Some (bs, ls')
  | _ => None
  end.
 *)

(*
Definition checkASP_fwd (p:Plc) (f:FWD) (params:ASP_PARAMS)
           (et:Evidence) (bs:BS) (ls:RawEv) : Opt EvidenceC :=
  match f with
  | COMP => res <- checkHH params bs ;;
           ret (hhc p params res et)
  | ENCR => res <- checkEE params bs ;;
           ret (eec p params res et)
  | _ => res <- checkASP params bs ;;

        ret (ggc p params bs mtc)
  end.
 *)

(*

Fixpoint build_app_comp_evC (et:Evidence) (ls:RawEv) (nonceGolden:BS) : Opt AppResultC :=
  match et with
  | mt => ret mtc_app
  | nn nid =>
    '(bs, _) <- peel_bs ls ;;
    res <- checkNonce nonceGolden bs ;;  (* TODO: proper nonce check *)
    ret (nnc_app nid res)
  | uu p fwd params et' =>
    match fwd with
    | COMP => ret mtc_app (* TODO hash check *)
      (*
      v <- checkHH params bs et' ;;
      ret (hhc p params v et') *)
    | ENCR =>
      '(bs, ls') <- peel_bs ls ;;
      decrypted_ls <- decrypt_bs_to_rawev bs params ;;
      rest <- build_app_comp_evC et' decrypted_ls nonceGolden ;;
      ret (eec_app p params passed_bs rest)
    (* TODO: consider encoding success/failure  of decryption for bs param
       (instead of default_bs)  *)
    | EXTD =>
      '(bs, ls') <- peel_bs ls ;;
      v <- checkGG params p bs ls' ;;
      rest <- build_app_comp_evC et' ls' nonceGolden ;;
      ret (ggc_app p params v rest)
    | KILL => ret mtc_app (* Do we ever reach this case? *)
    | KEEP => build_app_comp_evC et' ls nonceGolden  (* ret mtc_app *) (* Do we ever reach this case? *)
    end
  | ss et1 et2 =>
      x <- build_app_comp_evC et1 (firstn (et_size et1) ls) nonceGolden ;;
      y <- build_app_comp_evC et2 (skipn (et_size et1) ls) nonceGolden  ;;
      ret (ssc_app x y)
  end.

Definition run_gen_appraise (t:Term) (p:Plc) (et:Evidence) (nonceGolden:BS) (ls:RawEv) :=
  fromSome mtc_app (build_app_comp_evC (eval t p et) ls nonceGolden).

Definition run_gen_appraise_w_nonce (t:Term) (p:Plc) (nonceIn:BS) (ls:RawEv) :=
  run_gen_appraise t p (nn 0) nonceIn ls.

*)

(*
Fixpoint build_app_comp_evC (et:Evidence) (ls:RawEv) : Opt EvidenceC :=
  match et with
  | mt => ret mtc

  | uu params p et' =>
    '(bs, ls') <- peel_bs ls ;;
    x <- build_app_comp_evC et' ls' ;;
    res <- checkASP params bs ;;
    ret (uuc params p res x)

  | gg p et' =>
    '(bs, ls') <- peel_bs ls ;;
    x <- build_app_comp_evC et' ls' ;;
    res <- checkSigBits ls' p bs ;;
    ret (ggc p res x)

  | hh p et =>
    '(bs, _) <- peel_bs ls ;;
    res <- checkHash et p bs ;;
    ret (hhc p res et)
  | nn nid =>
    '(bs, _) <- peel_bs ls ;;
    res <- checkNonce nid bs ;;
    ret (nnc nid res)

  | ss et1 et2 =>
    x <- build_app_comp_evC et1 (firstn (et_size et1) ls) ;;
    y <- build_app_comp_evC et2 (skipn (et_size et1) ls) ;;
    ret (ssc x y)
  | pp et1 et2 =>
    x <- build_app_comp_evC et1 (firstn (et_size et1) ls) ;;
    y <- build_app_comp_evC et2 (skipn (et_size et1) ls) ;;
    ret (ppc x y)
  end.
*)

(*
(* *** Extra AM Monad defs *** *)

Definition am_add_trace (tr':list Ev) : AM_St -> AM_St :=
  fun '{| am_nonceMap := nm;
        am_nonceId := ni;
        st_aspmap := amap;
        st_sigmap := smap;
        st_hshmap := hmap;
        am_st_trace := tr;
        checked := cs |} =>
    mkAM_St nm ni amap smap hmap (tr ++ tr') cs.

Definition am_add_tracem (tr:list Ev) : AM unit :=
  modify (am_add_trace tr).

Definition am_run_cvm (annt:AnnoTerm) (e:EvidenceC) (et:Evidence) : AM EvidenceC :=
  let start_st := (mk_st e et [] 0) in
  let end_st := (run_cvm annt start_st) in
  am_add_tracem (st_trace end_st) ;;
  ret (st_ev end_st).

Definition am_run_cvm_comp{A:Type} (comp:CVM A) : AM A :=
  let '(cvm_res, vmst') := (runSt comp empty_vmst) in
  match cvm_res with
  | Some v =>
    am_add_tracem (st_trace vmst') ;;
    ret v
  | _ => failm
  end.

Require Import Maps.

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

Definition am_get_hsh_golden_val (p:Plc) (et:Evidence): AM BS :=
  (*
    m <- gets st_aspmap ;;
    let maybeId := map_get m (p,i) in
    match maybeId with
    | Some i' => ret i'
    | None => failm
    end.
   *)
  ret 0.

Definition am_check_hsh_eq (gv:BS) (actual:BS) : AM BS :=
  ret 1.
*)


Require Import Lia.
Require Import Program.Basics.
From hahn Require Import Hahn.
From PromisingLib Require Import Basic Language.
From imm Require Import Events Execution TraversalConfig Traversal
     Prog ProgToExecution ProgToExecutionProperties imm_s imm_s_hb
     CombRelations SimTraversal.
Require Import AuxRel.
Require Import AuxDef.
Require Import ImmProperties.
Require Import EventStructure.
Require Import Consistency.
Require Import Execution.
Require Import EventToAction.
Require Import LblStep.
Require Import SimRelCont.
Require Import SimRelEventToAction.
Require Import ProgES.
Require Import SimRel.

Set Implicit Arguments.
Local Open Scope program_scope.

Section SimRelInit.

  Variable prog : stable_prog_type.
  Variable S : ES.t.
  Variable G : execution.
  Variable sc : relation actid.
  Variable TC : trav_config.
  Variable X : actid -> eventid.

  Notation "'SE'" := ES.acts_set.
  Notation "'SEinit'" := ES.acts_init_set.
  Notation "'SEninit'" := ES.acts_ninit_set.
  Notation "'Stid'" := ES.tid.
  Notation "'Slab'" := ES.lab.
  Notation "'Sloc' S" := (loc S.(ES.lab)) (at level 1).
  Notation "'K'" := ES.cont_set.

  Notation "'STid' S t" := (fun x => Stid S x = t) (at level 1).

  Notation "'SR'" := (fun a => is_true (is_r Slab a)).
  Notation "'SW'" := (fun a => is_true (is_w Slab a)).
  Notation "'SF'" := (fun a => is_true (is_f Slab a)).
  Notation "'SRel'" := (fun a => is_true (is_rel Slab a)).

  Notation "'Ssb'" := ES.sb.
  Notation "'Scf'" := ES.cf.
  Notation "'Srmw'" := ES.rmw.
  Notation "'Sjf'" := ES.jf.
  Notation "'Sjfi'" := ES.jfi.
  Notation "'Sjfe'" := ES.jfe.
  Notation "'Srf'" := ES.rf.
  Notation "'Srfi'" := ES.rfi.
  Notation "'Srfe'" := ES.rfe.
  Notation "'Sco'" := ES.co.
  Notation "'Sew'" := ES.ew.

  Notation "'Srs'" := Consistency.rs.
  Notation "'Srelease'" := Consistency.release.
  Notation "'Ssw'" := Consistency.sw.
  Notation "'Shb'" := Consistency.hb.

  Notation "'thread_syntax' tid"  :=
    (Language.syntax (thread_lts tid)) (at level 10, only parsing).

  Notation "'thread_st' tid" :=
    (Language.state (thread_lts tid)) (at level 10, only parsing).

  Notation "'thread_init_st' tid" :=
    (Language.init (thread_lts tid)) (at level 10, only parsing).

  Notation "'thread_cont_st' tid" :=
    (fun st => existT _ (thread_lts tid) st) (at level 10, only parsing).

  Notation "'GE'" := G.(acts_set).
  Notation "'GEinit'" := (is_init ∩₁ GE).
  Notation "'GEninit'" := ((set_compl is_init) ∩₁ GE).

  Notation "'Glab'" := (Execution.lab G).
  Notation "'Gloc'" := (Events.loc (lab G)).
  Notation "'Gtid'" := (Events.tid).

  Notation "'GTid' t" := (fun x => Gtid x = t) (at level 1).
  Notation "'GNTid' t" := (fun x => Gtid x <> t) (at level 1).

  Notation "'GR'" := (fun a => is_true (is_r Glab a)).
  Notation "'GW'" := (fun a => is_true (is_w Glab a)).
  Notation "'GF'" := (fun a => is_true (is_f Glab a)).

  Notation "'GRel'" := (fun a => is_true (is_rel Glab a)).
  Notation "'GAcq'" := (fun a => is_true (is_acq Glab a)).

  Notation "'Gsb'" := (Execution.sb G).
  Notation "'Grmw'" := (Execution.rmw G).
  Notation "'Grf'" := (Execution.rf G).
  Notation "'Gco'" := (Execution.co G).

  Notation "'Grs'" := (imm_s_hb.rs G).
  Notation "'Grelease'" := (imm_s_hb.release G).
  Notation "'Gsw'" := (imm_s_hb.sw G).
  Notation "'Ghb'" := (imm_s_hb.hb G).

  Notation "'Gfurr'" := (furr G sc).

  Notation "'C'"  := (covered TC).
  Notation "'I'"  := (issued TC).

  Notation "'Gfurr'" := (furr G sc).

  Lemma simrel_init
        (nInitProg : ~ IdentMap.In tid_init prog)
        (PExec : program_execution (stable_prog_to_prog prog) G)
        (WF : Execution.Wf G)
        (CONS : imm_consistent G sc)
        (nLocsEmpty : g_locs G <> [])
        (GCLOS : forall tid m n (LT : m < n) (NE : GE (ThreadEvent tid n)),
            GE (ThreadEvent tid m)) :
    let Sinit := prog_g_es_init prog G in
    simrel_consistent prog Sinit G sc
                      (init_trav G)
                      (ES.acts_set Sinit)
                      (fun t => IdentMap.In t prog).
  Proof.
    clear S TC X.
    assert (simrel_e2a (prog_g_es_init prog G) G sc) as HH.
    { by apply simrel_e2a_init. }
    simpls.
    red. splits.
    2: by apply prog_g_es_init_consistent.
    constructor; auto.
    { apply prog_g_es_init_wf; auto. }
    { apply init_trav_coherent; auto. }
    { constructor; eauto.
      2: basic_solver.
      simpls. ins.
      split.
      { apply rmw_from_non_init in RMW; auto.
        generalize RMW. basic_solver. }
      apply WF.(rmw_in_sb) in RMW.
      apply no_sb_to_init in RMW.
      generalize RMW. basic_solver. }
    { constructor.
      all: unfold ES.cf_free, vis, cc, ES.acts_init_set.
      all: autorewrite with prog_g_es_init_db; auto.
      all: try basic_solver.
      { rewrite prog_g_es_init_w at 1. type_solver. }
      unfolder. ins. splits; auto.
      unfold cc.
      ins. desf.
      exfalso.
      eapply prog_g_es_init_cf; eauto. }
    { constructor.
      all: try by (ins;
                   match goal with
                   | H : ES.cont_set _ _ |- _ =>
                     apply prog_g_es_init_K in H; desf
                   end).
      5: { ins. apply prog_g_es_init_K in INKi; desf.
           erewrite steps_same_eindex; eauto.
           { by unfold init. }
           apply wf_thread_state_init. }
      { ins. red in INK.
        rewrite prog_g_es_init_alt in *.
        unfold ES.init, prog_init_K, ES.cont_thread in *.
        simpls.
        apply in_map_iff in INK. desf. }
      { ins. apply prog_g_es_init_K in INK. desf.
        eapply wf_thread_state_steps.
        2: { simpls. apply eps_steps_in_steps. eauto. }
        apply wf_thread_state_init. }
      { ins.
        assert (exists xst,
                   IdentMap.find thread prog = Some xst /\
                   lprog = projT1 xst) as [xst [XST]];
          subst.
        { unfold stable_prog_to_prog in *.
          rewrite IdentMap.Facts.map_o in INPROG.
          unfold option_map in *. desf.
          eauto. }
        unfold prog_g_es_init, ES.init, prog_init_K, ES.cont_thread,
        ES.cont_set in *.
        simpls.
        eexists. splits.
        { apply in_map_iff.
          exists (thread, xst). splits. simpls.
            by apply IdentMap.elements_correct. }
        destruct xst as [lprog BB]. simpls.
        pose (AA :=
                @proj2_sig
                  _ _
                  (get_stable thread (init lprog) BB
                              (rt_refl state (step thread) (init lprog)))).
        red in AA. desf. }
      ins.
      apply eps_steps_in_steps.
      unfold prog_g_es_init, ES.init, prog_init_K, ES.cont_thread,
      ES.cont_set in *.
      simpls.
      apply in_map_iff in INK.
      destruct INK as [xst [INK REP]].
      apply pair_inj in INK. destruct INK as [AA INK].
      rewrite <- AA in *.
      inv INK.
      destruct xst as [thread [xprog BB]]. simpls.
      assert (xprog = lprog); subst.
      { clear -REP INPROG.
        apply IdentMap.elements_complete in REP.
        unfold stable_prog_to_prog in *.
        rewrite IdentMap.Facts.map_o in INPROG.
        unfold option_map in *. desf. }
      pose (AA :=
              @proj2_sig
                _ _
                (get_stable thread (init lprog) BB
                            (rt_refl state (step thread) (init lprog)))).
      red in AA. desf. }
    { unfold contsimstate.
      ins.
      unfold stable_prog_to_prog in INPROG.
      rewrite IdentMap.Facts.map_o in INPROG.
      unfold option_map in *. desf.
      match goal with
      | H : IdentMap.find _ _ = Some _ |- _ => rename H into INP
      end.
      destruct s as [lprog BB].
      pose (AA :=
              @proj2_sig
                _ _
                (get_stable thread (init lprog) BB
                            (rt_refl state (step thread) (init lprog)))).
      assert
        (K (prog_g_es_init prog G)
           (CInit thread,
            existT _
              (thread_lts thread)
              (proj1_sig
                 (get_stable thread (init lprog) BB
                             (rt_refl state (step thread) (init lprog))))))
          as INK.
      { unfold prog_g_es_init, ES.init, prog_init_K, ES.cont_thread,
        ES.cont_set in *.
        simpls.
        apply in_map_iff.
        eexists. splits.
        2: { apply IdentMap.elements_correct; eauto. }
        done. }

      exists (CInit thread). eexists.
      splits; eauto.
      { arewrite
          ((fun _ : eventid =>
              tid_init = ES.cont_thread (prog_g_es_init prog G)
                                        (CInit thread)) ≡₁ ∅).
        2: basic_solver.
        split; [|basic_solver].
        unfolder. ins. apply nInitProg.
        apply IdentMap.Facts.in_find_iff. desf.
        destruct (IdentMap.find tid_init prog); desf. }
      red in AA. desf.
      red. splits; ins.
      { erewrite steps_same_eindex; eauto.
        2: by eapply wf_thread_state_init.
        simpls.
        split; [|lia].
        unfold is_init. basic_solver. }

      unfold prog_g_es_init, ES.init, prog_init_K, ES.cont_thread,
      ES.cont_set in *. simpls.
      apply in_map_iff in INK.
      destruct INK as [[tid [lprog' BB']] [INK REP]].
      apply pair_inj in INK. destruct INK as [AA INK].
      assert (tid = thread) as TT by inv AA.
      rewrite TT in *.
      inv INK. desf.
      apply RegMap.elements_complete in REP.
      cdes PExec.
      edestruct (PExec1 thread lprog) as [pe [CC DD]].
      { unfold stable_prog_to_prog.
        rewrite IdentMap.Facts.map_o. unfold option_map.
        desf. }
      cdes CC.
      exists s.
      red. splits.
      2,3: by desf.
      eapply steps_to_eps_steps_steps; eauto.
        by apply terminal_stable. }
    { simpls.
      arewrite (GEinit ∪₁ dom_rel (Gsb^? ⨾ ⦗GEinit⦘) ≡₁ GEinit).
      { rewrite (no_sb_to_init G). basic_solver. }
      split.
      2: { rewrite prog_g_es_init_init. apply HH. }
      apply set_subset_inter_r. splits.
      2: by apply HH.
      unfold e2a. unfolder. ins. desf. }
    { unfold prog_g_es_init, prog_l_es_init, ES.init. basic_solver. }
    { eapply eq_dom_mori; eauto.
      2: by apply prog_g_es_init_same_lab.
      red. basic_solver. }
    { simpls. rewrite WF.(rmw_in_sb). rewrite no_sb_to_init.
      basic_solver. }
    { unfold prog_g_es_init, ES.init. basic_solver. }
    { unfold prog_g_es_init, ES.init. basic_solver. }
    { unfold prog_g_es_init, ES.init. basic_solver. }
    { unfold prog_g_es_init, ES.init. basic_solver. }
    { unfold ES.jfe, prog_g_es_init, ES.init. basic_solver. }
    { rewrite prog_g_es_init_alt. unfold ES.init. basic_solver. }
    unfold release.
    arewrite (is_rel (ES.lab (prog_g_es_init prog G)) ⊆₁ ∅).
    2: basic_solver 20.
    unfolder. ins.
    pose proof (prog_g_es_init_lab prog G x) as AA.
    unfold prog_g_es_init, ES.init, is_rel, Events.mod, mode_le in *. simpls.
    desf.
  Qed.

End SimRelInit.


From Coq Require Import Bool List ListSet.
Import ListNotations.

From CasperCBC
  Require Import
    Lib.Preamble
    Lib.ListExtras
    Lib.ListSetExtras
    Lib.Measurable
    VLSM.Common
    VLSM.Decisions
    VLSM.CBC.FullNode.Validator.State
    VLSM.CBC.FullNode.Validator.Equivocation
    VLSM.Equivocation
    VLSM.ObservableEquivocation
    VLSM.CBC.FullNode.Client
    .

(** * VLSM Full Node Composite Validator *)

Section CompositeValidator.

  Context
    {C V : Type}
    {about_C : StrictlyComparable C}
    {about_V : StrictlyComparable V}
    {Hmeasurable : Measurable V}
    {Hrt : ReachableThreshold V}
    {Hestimator : Estimator (state C V) C}
    (eq_V := @strictly_comparable_eq_dec _ about_V)
    (message := State.message C V)
    (message_preceeds_dec := validator_message_preceeds_dec C V)
    .
  Existing Instance eq_V.
  Existing Instance message_preceeds_dec.

  Definition full_node_validator_observable_messages_fn
    (s : state C V)
    (v : V)
    : set message
    :=
    filter (fun m => bool_decide (sender m = v)) (get_message_set s).

    Definition full_node_validator_state_validators
    (s : state C V)
    : set V
    :=
    full_node_client_state_validators (get_message_set s).

  Instance full_node_validator_observable_messages
    : observable_events (state C V) message
    :=
    state_observable_events_instance (state C V) V message _
      full_node_validator_observable_messages_fn full_node_validator_state_validators.

  Lemma full_node_validator_has_been_observed_iff
    (s : state C V)
    (m : message)
    : has_been_observed s m <-> In m (get_message_set s).
  Proof.
    simpl.
    unfold observable_events_has_been_observed.
    unfold state_observable_events_fn.
    split; intro H.
    - apply union_fold in H.
      destruct H as [needle [Hm Hneedle]] .
      apply in_map_iff in Hneedle.
      destruct Hneedle as [v0 [Hneedle Hv0]].
      subst needle.
      apply filter_In in Hm.
      destruct Hm as [Hm Hv0eq].
      assumption.
    - apply union_fold.
      exists (full_node_validator_observable_messages_fn s (sender m)).
      split.
      * apply filter_In.
        split; [assumption|].
        apply bool_decide_eq_true. reflexivity.
      * apply in_map_iff.
        exists (sender m). split; [intuition|].
        apply set_map_exists.
        exists m. split; [assumption|reflexivity].
  Qed.

  Instance full_node_validator_observation_based_equivocation_evidence
    : observation_based_equivocation_evidence (state C V) V message _ decide_eq _ message_preceeds_dec full_node_message_subject_of_observation
    :=
    observable_events_equivocation_evidence _ _ _ _
      full_node_validator_observable_messages_fn full_node_validator_state_validators
      _ message_preceeds_dec full_node_message_subject_of_observation.

  Instance full_node_validator_observation_based_equivocation_evidence_dec
    : RelDecision (@equivocation_evidence _ _ _ _ _ _ _ _ full_node_validator_observation_based_equivocation_evidence)
    :=
    observable_events_equivocation_evidence_dec _ _ _ _
      full_node_validator_observable_messages_fn full_node_validator_state_validators
      _ _ message_preceeds_dec full_node_message_subject_of_observation.

  Lemma full_node_validator_state_validators_nodup
    (s : state C V)
    : NoDup (full_node_validator_state_validators s).
  Proof.
    apply set_map_nodup.
  Qed.

  Definition validator_basic_equivocation
    : basic_equivocation (state C V) V
    := @basic_observable_equivocation (state C V) V message
        message_eq _ (validator_message_preceeds_dec C V) full_node_validator_observable_messages full_node_message_subject_of_observation full_node_validator_observation_based_equivocation_evidence _ _ _  full_node_validator_state_validators full_node_validator_state_validators_nodup.

  (** ** Full-node validator VLSM instance

  Here we define a VLSM for a full-node validator identifying itself as
  <<v>> when sending messages.

  The validator and incorporates messages (sent by other validators), and
  creates and sends new messages proposing consensus values estimated based
  on its current state, signing them with its name and current state.

  Unlike the client, no equivocation check is done within the validator upon
  receiving a new message.
  *)
  Definition labelv : Type := option C.

  Definition vtransitionv
    (v : V)
    (l : labelv)
    (som : state C V * option message)
    : state C V * option message
    :=
    let (s, om) := som in
    let (msgs, final) := s in
    match l with
    | None => match om with
             | None => som
             | Some msg => pair (pair (set_add decide_eq msg msgs) final) None
           end
    | Some c =>
      let msg := Msg c v (make_justification s) in
      pair (pair (set_add decide_eq msg msgs) (Some msg)) (Some msg)
    end.

  Lemma vtransitionv_inv_out
    (v : V)
    (l : labelv)
    (s s' : state C V)
    (om : option message)
    (m' : message)
    (Ht : vtransitionv v l (s, om) = pair s' (Some m'))
    : s' = pair (set_add decide_eq m' (get_message_set s)) (Some m')
    /\ get_justification m' = make_justification s
    /\ sender m' = v
    /\ exists (c : C), l = Some c.
  Proof.
    unfold vtransitionv in Ht. destruct s as (msgs, final).
    destruct l as [c|].
    - inversion Ht. repeat split; try reflexivity. exists c. reflexivity.
    - destruct om as [msg|]; inversion Ht.
  Qed.

  Definition valid_validator
    (l : labelv)
    (som : state C V * option message)
    : Prop
    :=
    let (s, om) := som in
    match l, om with
    | None, None => True
    | None, Some msg =>
      ~In msg (get_message_set s)
      /\
      incl (get_message_set (unmake_justification (get_justification msg))) (get_message_set s)
    | Some c, None =>
      @estimator (state C V) C Hestimator s c
    | _,_ => False
    end.

  Instance VLSM_type_full_validator : VLSM_type message :=
    { state := state C V
    ; label := labelv
    }.

  Definition initial_state_prop
    (s : state C V)
    : Prop
    :=
    s = pair [] None.

  Definition state0 : {s | initial_state_prop s} :=
    exist _ (pair [] None) eq_refl.

  Definition initial_message_prop (m : message) : Prop := False.

  Instance LSM_full_validator : VLSM_sign VLSM_type_full_validator :=
    { initial_state_prop := initial_state_prop
    ; initial_message_prop := initial_message_prop
    ; s0 := state0
    ; m0 := State.message0
    ; l0 := None
    }.

  Definition VLSM_full_validator_machine (v : V) : VLSM_class LSM_full_validator :=
    {| transition := vtransitionv v
     ; valid := valid_validator
    |}.

  Definition VLSM_full_validator (v : V) : VLSM message :=
    mk_vlsm (VLSM_full_validator_machine v).

  Existing Instance observable_messages.

  Definition full_node_validator_vlsm_observable_messages
    (v : V)
    : vlsm_observable_events (VLSM_full_validator v) full_node_message_subject_of_observation.
  Proof.
    split; intros.
    - replace s with (@nil message, @None message) in He by assumption.
      inversion He.
    - inversion His.
    - destruct som as (s, om). destruct s as (msgs, final).
      destruct l as [c|]; [|destruct om as [msg|]]; inversion Ht.
      subst. clear Ht.
      match type of H with
      | context[Msg _ _ ?s] => remember s as j
      end.
      apply full_node_validator_has_been_observed_iff.
      simpl.
      apply set_add_iff.
      destruct H as [Hmsg | Hj]; intuition.
      right.
      apply in_unmake_justification in Hj.
      apply in_make_message_set.
      subst.
      destruct final; assumption.
  Qed.

Section proper_sent_received.
  Context
    (v : V)
    (vlsm := VLSM_full_validator v)
    (bvlsm := pre_loaded_with_all_messages_vlsm vlsm)
    .

  Lemma validator_protocol_state_nodup
    (s : state C V)
    (Hs : protocol_state_prop bvlsm s)
    : NoDup (get_message_set s).
  Proof.
    induction Hs using protocol_state_prop_ind.
    - inversion Hs. constructor.
    - destruct Ht as [_ Ht].
      simpl in Ht. unfold vtransition in Ht. simpl in Ht.
      destruct s as (msgs, final).
      destruct l as [c|].
      + apply pair_equal_spec in Ht. destruct Ht as [Hs' _].
        subst s'. apply set_add_nodup. assumption.
      + destruct om as [msg|]; inversion Ht.
        * apply set_add_nodup. assumption.
        * assumption.
  Qed.

  Lemma vtransition_inv_out
    (l : label)
    (s s' : state C V)
    (om : option message)
    (m' : message)
    (Ht : vtransition bvlsm l (s, om) = pair s' (Some m'))
    : s' = pair (set_add decide_eq m' (get_message_set s)) (Some m')
    /\ get_justification m' = make_justification s
    /\ sender m' = v
    /\ exists (c : C), l = Some c.
  Proof.
    apply vtransitionv_inv_out in Ht. assumption.
  Qed.

  Lemma protocol_transition_inv_out
    (l : label)
    (s s' : state C V)
    (om : option message)
    (m' : message)
    (Ht : protocol_transition bvlsm l (s, om) (s', Some m'))
    : s' = pair (set_add decide_eq m' (get_message_set s)) (Some m')
    /\ get_justification m' = make_justification s
    /\ sender m' = v
    /\ exists (c : C), l = Some c.
  Proof.
    destruct Ht as [_ Ht]. apply vtransition_inv_out in Ht. assumption.
  Qed.

  Lemma protocol_transition_inv_in
    (l : label)
    (s s' : state C V)
    (m : message)
    (om' : option message)
    (Ht : protocol_transition bvlsm l (s, Some m) (s', om'))
    : s' = pair (set_add decide_eq m (get_message_set s)) (last_sent s)
    /\ om' = None
    /\ ~In m (get_message_set s)
    /\ incl
        (unmake_message_set (justification_message_set (get_justification m)))
        (get_message_set s)
    /\ protocol_state_prop bvlsm s
    /\ protocol_message_prop bvlsm m
    /\ protocol_state_prop bvlsm s'.
  Proof.
    pose Ht as Hs'.
    apply protocol_transition_destination in Hs'.
    destruct Ht as [[Hs [Hm Hv]] Ht].
    simpl in Ht. unfold vtransition in Ht. simpl in Ht.
    simpl in Hv. unfold vvalid in Hv. simpl in Hv.
    destruct l as [c|]; try inversion Hv.
    destruct s as (msgs, final).
    inversion Ht. subst. simpl.
    repeat split; try reflexivity; assumption.
  Qed.

  Lemma last_sent_in_messages
    (s : state C V)
    (Hs : protocol_state_prop bvlsm s)
    (lst : message)
    (Hlst : last_sent s = Some lst)
    : In lst (get_message_set s).
  Proof.
    induction Hs using protocol_state_prop_ind.
    - inversion Hs. subst s. inversion Hlst.
    - destruct Ht as [_ Ht]. simpl in Ht. unfold vtransition in Ht. simpl in Ht.
      destruct s as (msgs, final).
      destruct l as [c|].
      + inversion Ht; subst. destruct final as [m|]; simpl in *
        ; inversion Hlst; apply set_add_iff; left; reflexivity.
      + destruct om as [msg|]; inversion Ht; subst
        ; simpl in Hlst; subst final
        ; specialize (IHHs eq_refl); simpl; [|assumption].
        apply set_add_iff. right. assumption.
  Qed.

  Lemma last_sent_justification_protocol
    (s : state C V)
    (Hs : protocol_state_prop bvlsm s)
    (lst : message)
    (Hlst : last_sent s = Some lst)
    (j := get_justification lst)
    : exists sj : state C V, protocol_state_prop bvlsm sj /\ make_justification sj = j.
  Proof.
    subst j.
    induction Hs using protocol_state_prop_ind.
    - inversion Hs. subst s. inversion Hlst.
    - destruct Ht as [[Hps [Hom Hv]] Ht].
       simpl in Ht. unfold vtransition in Ht. simpl in Ht.
      destruct s as (msgs, final).
      destruct l as [c|].
      + inversion Ht; subst.
        exists (msgs, final).
        destruct final as [m|]; simpl in *; inversion Hlst; simpl
        ; split; try assumption; reflexivity.
      + destruct om as [msg|]; inversion Ht; subst
        ; simpl in Hlst; subst final
        ; specialize (IHHs eq_refl); simpl; assumption.
  Qed.

  Lemma in_protocol_state
    (s : state C V)
    (Hs : protocol_state_prop bvlsm s)
    (m : message)
    (Hm : In m (get_message_set s))
    : incl (unmake_message_set (justification_message_set (get_justification m))) (get_message_set s).
  Proof.
    induction Hs using protocol_state_prop_ind.
    - inversion Hs. subst s. inversion Hm.
    - destruct Ht as [[Hps [Hom Hv]] Ht].
      simpl in Ht. unfold vtransition in Ht. simpl in Ht.
      simpl in Hv. unfold vvalid in Hv. simpl in Hv.
      destruct s as (msgs, final).
      destruct l as [c|].
      + inversion Ht; subst s' om';clear Ht;simpl in * |- *.
        apply set_add_iff in Hm.
        intros msg Hmsg; apply set_add_iff; right.
        destruct Hm;[|apply IHHs;assumption].
        subst m; clear -Hmsg;simpl in Hmsg.
        apply make_unmake_message_set_eq.
        destruct final;assumption.
      + destruct om as [msg|]; inversion Ht; subst; clear Ht
        ; simpl in IHHs; simpl in Hv; simpl
        ; [|apply IHHs; assumption].
        destruct Hv as [Hnmsg Hv].
        apply set_add_iff in Hm.
        destruct Hm as [Heqm | Hm].
        * subst m.
          apply incl_tran with msgs; try assumption.
          intros x Hx; apply set_add_iff. right. assumption.
        * specialize (IHHs Hm).
          apply incl_tran with msgs; try assumption.
          intros x Hx; apply set_add_iff. right. assumption.
  Qed.

  Lemma has_been_sent_in_futures
    (s1 s2 : state C V)
    (Hs : in_futures bvlsm s1 s2)
    : incl (State.sent_messages s1) (State.sent_messages s2).
  Proof.
    unfold in_futures in Hs. destruct Hs as [tr Htr].
    induction Htr; intros.
    - apply incl_refl.
    - revert IHHtr. apply incl_tran.
      clear -H.
      destruct H as [_ Ht]. simpl in Ht. unfold vtransition in Ht. simpl in Ht.
      destruct s' as (msgs, final).
      destruct l as [c|].
      + inversion Ht; subst; clear Ht. unfold State.sent_messages. simpl.
        destruct final as [m|]; subst; simpl in *; try apply incl_nil_l.
        destruct m as (c0, v0, j0). intros m Hm.
        apply set_add_iff. right. assumption.
      + destruct iom as [msg|]; inversion Ht; apply incl_refl.
  Qed.

  Lemma get_messages_in_futures
    (s1 s2 : state C V)
    (Hs : in_futures bvlsm s1 s2)
    : incl (get_message_set s1) (get_message_set s2).
  Proof.
    unfold in_futures in Hs. destruct Hs as [tr Htr].
    induction Htr; intros.
    - apply incl_refl.
    - revert IHHtr. apply incl_tran.
      clear -H.
      destruct H as [_ Ht]. simpl in Ht. unfold vtransition in Ht. simpl in Ht.
      destruct s' as (msgs, final).
      destruct l as [c|].
      + inversion Ht; subst; clear Ht. unfold get_message_set. simpl.
        intros m Hm. apply set_add_iff. right. assumption.
      + destruct iom as [msg|]; inversion Ht; try apply incl_refl.
        simpl. intros m Hm. apply set_add_iff. right. assumption.
  Qed.

  Lemma has_been_sent_protocol_transition
    (l : vlabel bvlsm)
    (s1 s2 : state C V)
    (iom oom : option message)
    (Hpt : protocol_transition bvlsm l (s1, iom) (s2, oom))
    (m : message)
    (Hs1 : ~ In m (State.sent_messages s1))
    : In m (State.sent_messages s2) <-> oom = Some m.
  Proof.
    destruct Hpt as [_ Ht]. simpl in Ht.
    unfold vtransition in Ht. simpl in Ht.
    destruct s1 as (msgs, final).
    destruct l as [c|]; inversion Ht; subst.
    + unfold State.sent_messages. simpl.  split; intro H.
      * apply set_add_iff in H.
        destruct H as [Heq | H]; subst; try reflexivity.
        elim Hs1. unfold State.sent_messages. simpl.
        destruct final; simpl in *; assumption.
      * inversion H; subst.
        apply set_add_iff. left. reflexivity.
    + destruct iom as [msg|]; inversion H0; subst; split; intro H
      ; try discriminate H
      ; elim Hs1
      ; assumption.
  Qed.

  Lemma has_been_sent_in_trace
    (s : state C V)
    (m: message)
    (is : state C V)
    (tr: list transition_item)
    (Htr: finite_protocol_trace_init_to bvlsm is s tr)
    (item: transition_item)
    (Hitem: In item tr)
    (Hm: output item = Some m)
    : In m (State.sent_messages s).
  Proof.
    apply in_split in Hitem.
    destruct Hitem as [l1 [l2 Hitem]]. subst tr.
    destruct Htr as [Htr Hinit].
    apply finite_protocol_trace_from_to_app_split in Htr.
    destruct Htr as [_ Htr].
    inversion Htr. subst. simpl in Hm. subst oom.
    assert (Hm0 : In m (State.sent_messages s0)).
    { clear -H4. destruct H4 as [_ Ht].
      simpl in Ht. unfold vtransition in Ht. simpl in Ht.
      change (state C V) with Common.state in is.
      destruct
        (finite_trace_last (is:Common.state) l1)
        as (msgs, final) in Ht.
      destruct l as [c|].
      - inversion Ht; subst; clear Ht.
        unfold State.sent_messages. simpl.
        apply set_add_iff. left. reflexivity.
      - destruct iom as [msg|]; inversion Ht.
    }
    assert (Hs0 : in_futures bvlsm s0 s).
    { exists l2. inversion Htr. assumption. }
    apply has_been_sent_in_futures with s0; assumption.
  Qed.

  Lemma has_been_sent_witness
    (s: state C V)
    (m: message)
    (Horacle: In m (State.sent_messages s))
    (start: Common.state)
    (Hstart: ~In m (State.sent_messages start))
    (prefix: list transition_item)
    (Hprefix: finite_protocol_trace_from_to (pre_loaded_with_all_messages_vlsm vlsm) start s prefix)
    : exists item : transition_item, In item prefix /\ output item = Some m.
  Proof.
    induction Hprefix.
    + elim Hstart. assumption.
    + simpl in *.
      specialize (IHHprefix Horacle).
      destruct oom as [om|]; try destruct (decide (om = m)); try subst om.
      * eexists. split;[left;reflexivity|reflexivity].
      * assert (Hs0 : ~In m (State.sent_messages s)).
        { intro Hbs.
          apply (has_been_sent_protocol_transition _ _ _ _ _ H _ Hstart) in Hbs.
          congruence.
        }
        specialize (IHHprefix Hs0) as [x [Hx Hm]].
        exists x. tauto.
      * assert (Hs0 : ~In m (State.sent_messages s)).
        { intro Hbs.
          apply (has_been_sent_protocol_transition _ _ _ _ _ H _ Hstart) in Hbs.
          discriminate Hbs.
        }
        specialize (IHHprefix Hs0) as [x [Hx Hm]].
        exists x. tauto.
  Qed.

  Lemma has_been_sent_in_trace_rev
    (s: state C V)
    (m: message)
    (Horacle: In m (State.sent_messages s))
    (is : state C V)
    (tr: list transition_item)
    (Htr: finite_protocol_trace_init_to bvlsm is s tr)
    : exists item : transition_item, In item tr /\ output item = Some m.
  Proof.
    destruct Htr as [Htr Hinit].
    apply has_been_sent_witness with s is; try assumption.
    inversion Hinit. intro. contradiction H0.
  Qed.

  Lemma has_been_received_in_futures
    (s1 s2 : state C V)
    (Hs : in_futures bvlsm s1 s2)
    : incl (State.received_messages s1) (State.received_messages s2).
  Proof.
    unfold State.received_messages.
    intros m Hm. apply set_diff_iff in Hm. apply set_diff_iff.
    destruct Hm as [Hm Hnm].
    specialize (get_messages_in_futures s1 s2 Hs _ Hm) as Hm1.
    split; try assumption.
    intro Hsm; elim Hnm.
    destruct Hs as [tr Htr].
    destruct
      (has_been_sent_witness s2 m Hsm s1 Hnm tr Htr)
      as [item [Hitem Hm']].
    apply in_split in Hitem. destruct Hitem as [l1 [l2 Hitem]].
    subst tr.
    apply finite_protocol_trace_from_to_app_split in Htr as [Hl1 Hl2].
    change Common.state in s1.
    remember
      (@finite_trace_last _ (@type _ bvlsm) s1 l1)
      as s1'.
    assert (Hs1' : in_futures bvlsm s1 s1')
      by (exists l1; assumption).
    assert (Hm1' : In m (get_message_set s1'))
      by (apply (get_messages_in_futures s1 s1' Hs1'); assumption).
    inversion Hl2. subst s' tl item.
    simpl in Hm'. subst oom.
    clear - Hm1' H4.
    destruct H4 as [_ Ht].
    simpl in Ht. unfold vtransition in Ht. simpl in Ht.
    destruct s1' as (msgs, final). simpl in *.
    destruct l as [c|].
    - inversion Ht; subst. destruct final as [m|]; clear Ht.
      + elim
        (in_justification_recursive'
          (Msg c v (LastSent (make_message_set msgs) m))
          msgs
          eq_refl
        ).
        assumption.
      + elim
        (in_justification_recursive'
          (Msg c v (NoSent (make_message_set msgs)))
          msgs
          eq_refl
        ).
        assumption.
    - destruct iom as [msg|]; inversion Ht.
  Qed.

  Lemma last_state_empty_segment
    (start: Common.state)
    (prefix: list transition_item)
    (Hprefix: finite_protocol_trace_from_to bvlsm start ([],None) prefix)
    (item : transition_item)
    (Hitem : In item prefix)
    : input item = None /\ output item = None /\ destination item = pair [] None /\ l item = None.
  Proof.
    remember ([],None) as sf in Hprefix.
    induction Hprefix using @finite_protocol_trace_from_to_rev_ind.
    - inversion Hitem.
    - apply in_app_iff in Hitem.
      subst sf. destruct H as [_ Ht].
      simpl in Ht. unfold vtransition in Ht. simpl in Ht.
      destruct s as [msgs final].
      destruct l as [c|];[discriminate Ht|].
      destruct iom as [msg|]; inversion Ht; subst; clear Ht.
      + contradict H0. apply set_add_not_empty.
      + destruct Hitem as [Hin|[<- |[]]];auto.
  Qed.

  Lemma last_state_empty_trace
    (is : state C V)
    (tr: list transition_item)
    (Htr: finite_protocol_trace_init_to bvlsm is ([], None) tr)
    (item : transition_item)
    (Hitem : In item tr)
    : input item = None /\ output item = None /\ destination item = pair [] None /\ l item = None.
  Proof.
    destruct Htr as [Htr _].
    specialize (last_state_empty_segment is tr Htr item Hitem) as H.
    assumption.
  Qed.

  Lemma sent_messages_prop
    (s : state C V)
    (Hs : protocol_state_prop bvlsm s)
    (m : message)
    : In m (State.sent_messages s) <->
    exists (sm : sent_messages vlsm s), proj1_sig sm = m.
  Proof.
    destruct Hs as [_om Hs].
    pose (protocol_is_trace bvlsm s _om Hs) as Htr.
    destruct Htr as [His | [is [tr [Htr _]]]];
      [inversion His; subst s|];split;intros.
    - inversion H.
    - destruct H as [[m0 Hm0] _].
      destruct Hm0 as [is [tr [Htr Hex]]];simpl in *.
      apply Exists_exists in Hex.
      destruct Hex as [item [Hitem Hout]].
      specialize (last_state_empty_trace is tr Htr item Hitem).
      intros [_ [Hnout _]].
      simpl in Hout.
      rewrite Hnout in Hout. discriminate Hout.
    - assert (Hm : selected_message_exists_in_some_preloaded_traces vlsm (field_selector output) s m).
      { exists is. exists tr. exists Htr.
        apply Exists_exists.
        apply (has_been_sent_in_trace_rev s m H is tr Htr).
      }
      exists (exist _ m Hm). reflexivity.
    - destruct H as [[m0 Hm] Heq].
      simpl in Heq. subst m0.
      destruct Hm as [ism [trm [Htrm Hexistm]]].
      apply Exists_exists in Hexistm.
      destruct Hexistm as [item [Hin Hout]].
      apply (has_been_sent_in_trace s m ism trm Htrm item Hin Hout).
  Qed.

  Lemma VLSM_full_validator_sent_consistency
    (s : vstate vlsm)
    (Hs : protocol_state_prop bvlsm s)
    (m : message)
    : selected_message_exists_in_some_preloaded_traces vlsm (field_selector output) s m <->
    selected_message_exists_in_all_preloaded_traces vlsm (field_selector output) s m.
  Proof.
    specialize (sent_messages_prop s Hs m) as Hin.
    split; intros.
    - intro is; intros.
      apply proj2 in Hin.
      spec Hin; try (exists (exist _ m H); reflexivity).
      specialize (has_been_sent_in_trace_rev s m Hin is tr Htr) as Hex.
      apply Exists_exists. assumption.
    - destruct Hs as [_om Hs].
      pose (protocol_is_trace bvlsm s _om Hs) as Htr.
      destruct Htr as [Hinit | [is [tr [Htr _]]]].
      + specialize (selected_message_exists_in_all_traces_initial_state vlsm s Hinit (field_selector output) m) as Hsm.
        elim Hsm. assumption.
      + exists is. exists tr. exists Htr.
        specialize (H is tr Htr). assumption.
  Qed.

  Definition VLSM_full_validator_send_oracle
    (s : vstate vlsm)
    (m : message) :
    Prop :=
    In m (State.sent_messages s).

  Global Instance VLSM_full_validator_send_oracle_dec : RelDecision VLSM_full_validator_send_oracle.
  Proof.
    unfold RelDecision; intros s m.
    unfold VLSM_full_validator_send_oracle.
    destruct (inb decide_eq m (State.sent_messages s)) eqn : eq_inb.
    - apply in_correct in eq_inb. left. intuition.
    - apply in_correct' in eq_inb. right. intuition.
  Qed.

  Global Instance VLSM_full_validator_has_been_sent : has_been_sent_capability vlsm.
  Proof.
    apply (@has_been_sent_capability_from_stepwise _ vlsm VLSM_full_validator_send_oracle _).
    split.
    - intros.
      simpl in H. unfold initial_state_prop in H.
      subst s. unfold VLSM_full_validator_send_oracle. intuition.
    - intros.
      unfold VLSM_full_validator_send_oracle in *.
      destruct H as [Hprotocol Htrans].
      unfold transition in Htrans. simpl in Htrans.
      unfold vtransition in Htrans. unfold transition in Htrans.
      unfold protocol_valid in Hprotocol.
      unfold valid in Hprotocol. simpl in Hprotocol.
      unfold vvalid in Hprotocol. unfold valid in Hprotocol.
      simpl in *.
      split; intros H.
      + unfold State.sent_messages in *. simpl in *.
        destruct s as [s_set s_pointer].
        destruct l eqn : eq_label.
        * simpl in *.
          destruct s_pointer eqn : eq_pointer.
          -- inversion Htrans.
             rewrite <- H1 in H.
             rewrite H2 in H.
             destruct om.
             ++ destruct m0 as [c0 v0 j] eqn : eq_m0.
                apply set_add_elim in H.
                rewrite H2.
                destruct H.
                ** left. f_equal. intuition.
                ** right. destruct m as [c1 v1 j0].
                   inversion H2.
                   subst j. simpl in *.
                   intuition.
             ++ simpl in H. intuition.
          -- simpl in *.
             inversion Htrans.
             rewrite <- H1 in H.
             simpl in H.
             destruct H;[|intuition].
             left. f_equal. intuition.
        * simpl in *.
          unfold State.sent_messages in *.
          destruct im eqn : eq_im.
          -- inversion Htrans.
             rewrite <- H1 in H.
             destruct s_pointer eqn : eq_pointer; simpl in *.
             ++ destruct m0 as [c0 v0 j] eqn : eq_m0.
                right. intuition.
             ++ simpl in H. intuition.
          -- inversion Htrans.
             rewrite <- H1 in H.
             destruct s_pointer eqn : eq_pointer; simpl in *.
             ++ destruct m as [c v0 j].
                right. intuition.
             ++ intuition.
      + destruct s as [s_set s_pointer].
        unfold State.sent_messages in *.
        destruct l eqn : eq_label.
        * simpl in *.
          destruct s_pointer eqn : eq_pointer; simpl in *.
          -- destruct m as [c0 v0 j] eqn : eq_m.
             inversion Htrans. subst om. simpl in *.
             apply set_add_iff.
             destruct H.
             ++ left. inversion H. intuition.
             ++ right. intuition.
          -- inversion Htrans. subst om. simpl in *.
             destruct H;[|intuition].
             left. inversion H. intuition.
        * destruct im eqn : eq_im.
          -- inversion Htrans.
             destruct s_pointer eqn : eq_pointer; simpl in *.
             ++ destruct m0 as [c0 v0 j] eqn : eq_m0.
                destruct H;[intuition congruence|intuition].
             ++ destruct H;[intuition congruence|intuition].
          -- inversion Htrans.
             destruct s_pointer eqn : eq_pointer; simpl in *.
             ++ destruct m as [c0 v0 j] eqn : eq_m.
                destruct H;[intuition congruence|intuition].
             ++ destruct H;[intuition congruence|intuition].
  Qed.

  Lemma get_sent_messages
    (s : state C V)
    (Hs : protocol_state_prop bvlsm s)
    : incl (State.sent_messages s) (get_message_set s).
  Proof.
    intros m Hm.
    apply sent_messages_prop in Hm; try assumption.
    destruct Hm as [[m0 Hm] Heq]. simpl in Heq. subst m0.
    apply VLSM_full_validator_sent_consistency in Hm; try assumption.
    destruct Hs as [_om Hs].
    pose (protocol_is_trace bvlsm s _om Hs) as Htr.
    destruct Htr as [Hinit | [is [tr [Htr _]]]].
    + elim (selected_message_exists_in_all_traces_initial_state vlsm s Hinit (field_selector output) m).
      assumption.
    + specialize (Hm is tr Htr).
      apply Exists_exists in Hm. destruct Hm as [item [Hitem Hm]].
      apply in_split in Hitem.
      destruct Hitem as [l1 [l2 Hitem]]. subst tr.
      destruct Htr as [Htr Hinit].
      apply finite_protocol_trace_from_to_app_split in Htr as [Hl1 Hl2].
      inversion Hl2. subst item tl.
      rewrite <- H1 in *.
      simpl in Hm. subst oom.
      apply protocol_transition_inv_out in H4.
      destruct H4 as [Hs0 [c Hc]].
      assert (Hfutures : in_futures bvlsm s0 s)
        by (exists l2;assumption).
      apply (get_messages_in_futures s0 s Hfutures).
      subst s0. simpl. apply set_add_iff. left. reflexivity.
  Qed.

  Definition VLSM_full_validator_receive_oracle
    (s : vstate vlsm)
    (m : message) :
    Prop :=
    In m (State.received_messages s).

  Global Instance VLSM_full_validator_receive_oracle_dec : RelDecision VLSM_full_validator_receive_oracle.
  Proof.
    unfold RelDecision; intros s m.
    unfold VLSM_full_validator_receive_oracle.
    destruct (inb decide_eq m (State.received_messages s)) eqn : eq_inb.
    - apply in_correct in eq_inb. left. intuition.
    - apply in_correct' in eq_inb. right. intuition.
  Qed.

  Global Instance VLSM_full_validator_has_been_received : has_been_received_capability vlsm.
  Proof.
    apply (@has_been_received_capability_from_stepwise _ vlsm VLSM_full_validator_receive_oracle _).
    split.
    - intros s H m.
      simpl in H. unfold initial_state_prop in H. subst s.
      unfold VLSM_full_validator_receive_oracle. simpl. intuition.
    - intros.
      unfold VLSM_full_validator_receive_oracle in *.
      destruct H as [Hprotocol Htrans].
      unfold transition in Htrans. simpl in Htrans.
      unfold vtransition in Htrans. unfold transition in Htrans.
      unfold protocol_valid in Hprotocol.
      unfold valid in Hprotocol. simpl in Hprotocol.
      unfold vvalid in Hprotocol. unfold valid in Hprotocol.
      simpl in *.
      split; intros H; unfold State.received_messages in *.
      + destruct s as [s_set s_pointer].
        destruct l eqn : eq_l; simpl in *.
        * destruct im;[intuition|].
          destruct s_pointer eqn : eq_pointer; simpl in *.
          -- inversion Htrans. subst s'. subst om.
             right. simpl in *.
             unfold State.sent_messages in *. simpl in *.
             destruct m as [c0 v0 j]; simpl in *.
             apply set_diff_iff in H; simpl in *.
             destruct H as [Hin Hnin].
             apply set_add_iff in Hin.
             destruct Hin.
             ++ subst msg.
                contradict Hnin.
                apply set_add_iff.
                left. intuition.
             ++ apply set_diff_iff.
                split;[intuition|].
                intros contra.
                contradict Hnin.
                apply set_add_iff.
                right. intuition.
          -- inversion Htrans. subst s'. subst om.
             right. simpl in *.
             unfold State.sent_messages in *. simpl in *.
             apply set_diff_iff in H; simpl in *.
             destruct H as [Hin Hnin].
             apply set_add_iff in Hin.
             destruct Hin.
             ++ subst msg.
                contradict Hnin; intuition.
             ++ apply set_diff_iff.
                split;[intuition|].
                intuition.
        * destruct im eqn : eq_im.
          -- inversion Htrans. subst s'. subst om.
             apply set_diff_iff in H.
             destruct H as [Hin Hnin]; simpl in *.
             apply set_add_iff in Hin.
             destruct Hin.
             ++ left. f_equal. intuition.
             ++ right. apply set_diff_iff.
                intuition.
          -- inversion Htrans. subst s'. subst om.
             apply set_diff_iff in H.
             destruct H as [Hin Hnin]; simpl in *.
             right. apply set_diff_iff.
             intuition.
       + destruct s as [s_set s_pointer] eqn : eq_s.
         destruct l eqn : eq_l; simpl in *.
         * destruct im;[intuition|].
           destruct s_pointer eqn : eq_pointer; simpl in *.
           -- inversion Htrans. subst s'. subst om.
              destruct H;[intuition congruence|].
              apply set_diff_iff in H.
              destruct H as [Hin Hnin].
              apply set_diff_iff.
              split.
              ++ apply set_add_iff. right. intuition.
              ++ intros contra.
                 unfold State.sent_messages in *; simpl in *.
                 destruct m as [c0 v0 j]; simpl in *.
                 apply set_add_iff in contra.
                 destruct contra.
                 ** specialize (in_justification_recursive' msg s_set) as Hjucrec.
                     spec Hjucrec. {
                      subst msg. simpl; intuition.
                    }
                    intuition.
                 ** intuition.
           -- destruct H;[intuition congruence|].
              inversion Htrans. subst s'. subst om.
              apply set_diff_iff in H. simpl in *.
              destruct H as [H _].
              apply set_diff_iff.
              split.
              ++ apply set_add_iff. right. intuition.
              ++ intros contra.
                 unfold State.sent_messages in contra. simpl in contra.
                 destruct contra;[|intuition].
                 specialize (in_justification_recursive' msg s_set) as Hjucrec.
                     spec Hjucrec. {
                      subst msg. simpl; intuition.
                    }
                  intuition.
         * unfold State.sent_messages in H.
           destruct im eqn : eq_im; simpl in *.
           -- destruct s_pointer eqn : eq_pointer; simpl in *.
              ++ destruct m0 as [c v0 j] eqn : eq_m0.
                 inversion Htrans.
                 subst s'. subst om. simpl.
                 destruct H.
                 ** inversion H.
                    subst msg.
                    apply set_diff_iff.
                    split.
                    --- apply set_add_iff. left. intuition.
                    --- intros contra.
                        apply set_add_iff in contra.
                        assert (Hpr : protocol_state_prop bvlsm s). {
                          destruct Hprotocol.
                          subst s. intuition.
                        }
                        assert (Hinm0 :In m0 s_set). {
                          specialize (last_sent_in_messages s Hpr m0).
                          subst s. subst m0. simpl. intuition.
                        }
                        destruct contra.
                        +++ subst m. subst m0. intuition.
                        +++ specialize (in_protocol_state s Hpr m0) as Hin_pr.
                            spec Hin_pr. {
                              subst s. simpl. intuition.
                            }
                            unfold incl in Hin_pr.
                            specialize (Hin_pr m).
                            subst m0. simpl in *.
                            specialize (get_sent_messages s Hpr) as Hincl.
                            unfold State.sent_messages in Hincl.
                            subst s. simpl in *.
                            unfold incl in Hincl.
                            specialize (Hincl m).
                            spec Hincl. {
                              apply set_add_iff. right.
                              intuition.
                            }
                            intuition.
                ** apply set_diff_iff in H.
                   apply set_diff_iff.
                   destruct H;split; [apply set_add_iff; right; intuition|intuition].
              ++ inversion Htrans. subst s'. subst om. simpl in *.
                 destruct H.
                 ** apply set_diff_iff.
                    split.
                    --- apply set_add_iff. inversion H. intuition.
                    --- intuition.
                 ** apply set_diff_iff.
                    apply set_diff_iff in H.
                    destruct H as [H _].
                    split;[apply set_add_iff;right;intuition|intuition].
           -- inversion Htrans. subst s'. subst om.
              destruct s_pointer eqn : eq_pointer; simpl in *.
              ++ destruct m as [c v0 j]. simpl in *.
                 destruct H;[intuition congruence|intuition].
              ++ destruct H;[intuition congruence|intuition].
  Qed.

  Lemma VLSM_full_validator_sent_messages_comparable'
    (s : vstate vlsm)
    (tr : list transition_item)
    (Htr : finite_protocol_trace bvlsm s tr)
    (prefix middle suffix : list transition_item)
    (item1 item2 : transition_item)
    (Htreq: tr = prefix ++ cons item1 middle ++ item2 :: suffix)
    (m1 m2 : message)
    (Hm1 : output item1 = Some m1)
    (Hm2 : output item2 = Some m2)
    : validator_message_preceeds _ _ m1 m2.
  Proof.
    rewrite app_assoc in Htreq.
    subst tr.
    destruct Htr as [Htr Hinit].
    apply finite_protocol_trace_from_app_iff in Htr.
    destruct Htr as [Htr1 Htr2].
    apply ptrace_add_default_last in Htr1 as Htr1'.
    specialize
      (has_been_sent_in_trace (finite_trace_last s (prefix ++ item1 :: middle))
        m1 s (prefix ++ item1 :: middle)
        (conj Htr1' Hinit)
        item1
      ) as Hm1'.
    spec Hm1'.
    { apply in_app_iff. right. left. reflexivity. }
    specialize (Hm1' Hm1).
    inversion Htr2. subst. simpl in Hm2. subst oom.
    apply protocol_transition_inv_out in H3.
    destruct H3 as [_ [Hjust _]].
    unfold validator_message_preceeds.
    unfold validator_message_preceeds_fn.
    destruct m2. simpl in Hjust.
    subst j. simpl.
    apply in_correct.
    apply in_unmake_message_set.
    apply in_make_justification.
    apply get_sent_messages; try assumption.
    apply finite_ptrace_last_pstate. assumption.
  Qed.

  Lemma VLSM_full_validator_sent_messages_comparable
    (s : vstate vlsm)
    (tr : list transition_item)
    (Htr : finite_protocol_trace bvlsm s tr)
    (m1 m2 : message)
    (Hm1 : trace_has_message(field_selector output) m1 tr)
    (Hm2 : trace_has_message (field_selector output) m2 tr)
    : m1 = m2 \/ validator_message_preceeds _ _ m1 m2 \/ validator_message_preceeds _ _ m2 m1.
  Proof.
    unfold trace_has_message in *.
    apply Exists_exists in Hm1. destruct Hm1 as [item1 [Hitem1 Hm1]].
    apply Exists_exists in Hm2. destruct Hm2 as [item2 [Hitem2 Hm2]].
    apply in_split in Hitem1.
    destruct Hitem1 as [prefix1 [suffix1 Hitem1]].
    rewrite Hitem1 in Hitem2.
    apply in_app_iff in Hitem2.
    destruct Hitem2 as [Hitem2 | [Heq | Hitem2]]
    ; try
      (apply in_split in Hitem2; destruct Hitem2 as [prefix2 [suffix2 Hitem2]]
      ; rewrite Hitem2 in Hitem1; clear Hitem2
      ).
    - right. right.
      rewrite <- app_assoc in Hitem1.
      apply
        (VLSM_full_validator_sent_messages_comparable'
          s tr Htr prefix2 suffix2 suffix1 item2 item1 Hitem1
          m2 m1 Hm2 Hm1
        ).
    - left. subst. simpl in Hm1, Hm2. rewrite Hm1 in Hm2. inversion Hm2. reflexivity.
    - right. left.
      apply
        (VLSM_full_validator_sent_messages_comparable'
          s tr Htr prefix1 prefix2 suffix2 item1 item2 Hitem1
          m1 m2 Hm1 Hm2
        ).
  Qed.

End proper_sent_received.

End CompositeValidator.


Require Import Bedrock.Prover Bedrock.Env.
Require Import Bedrock.ILEnv.
Require Bedrock.provers.AssumptionProver.
Require Bedrock.provers.ReflexivityProver.
Require Bedrock.provers.WordProver.
Require Bedrock.provers.ArrayBoundProver.

Set Implicit Arguments.
Set Strict Implicit.

(** * The Combo Prover **)

Definition comboTypes := repr_combine bedrock_types_r sep.Array.types_r.
Definition comboFuncs types' := repr_combine (bedrock_funcs_r (repr comboTypes types'))
  (Array.funcs_r (repr comboTypes types')).

Definition ComboProver : ProverPackage :=
{| ProverTypes := comboTypes
 ; ProverFuncs := comboFuncs
 ; Prover_correct := fun ts fs => composite_ProverT_correct
   (composite_ProverT_correct (provers.AssumptionProver.assumptionProver_correct _)
     (provers.ReflexivityProver.reflexivityProver_correct _))
   (composite_ProverT_correct
     (provers.WordProver.wordProver_correct (types' := repr comboTypes ts) (repr (comboFuncs ts) fs))
     (provers.ArrayBoundProver.boundProver_correct (types' := repr comboTypes ts) (repr (comboFuncs ts) fs)))
|}.