Require Import FunctionalExtensionality.
Require Import Structures.OrderedType.
Require Import Structures.OrderedTypeEx.
Require Import Omega.
Require Import List.
Require Import Mem.
Require Import PredCrash.
Require Import AsyncDisk.
Require Import Word.
Require Import String.

Import ListNotations.

Set Implicit Arguments.

(** * The programming language *)

Parameter vartype : Type.
Parameter vartype_eq_dec : forall (x y : vartype), {x=y}+{x<>y}.

Polymorphic Inductive var_value : Type :=
  | Any : forall (T : Type), T -> var_value.

(** single program *)
Inductive prog : Type -> Type :=
  | Ret T (v: T) : prog T
  | Read (a: addr) : prog valu
  | Write (a: addr) (v: valu) : prog unit
  | Sync : prog unit
  | Trim (a: addr) : prog unit
  | VarAlloc (T : Type) (v : T) : prog vartype
  | VarDelete (i : vartype) : prog unit
  | VarGet (i : vartype) (T : Type) : prog T
  | VarSet (i : vartype) (T : Type) (v : T) : prog unit
  | AlertModified : prog unit
  | Debug (s: string) (n: nat) : prog unit
  | Rdtsc: prog nat
  | Hash (sz: nat) (buf: word sz) : prog (word hashlen)
  | Hash2 (sz1 sz2: nat) (buf1 : word sz1) (buf2 : word sz2) : prog (word hashlen)
  | Bind T T' (p1: prog T) (p2: T -> prog T') : prog T'.

Arguments Ret {T} v.
Arguments VarAlloc {T} v.
Arguments VarGet i {T}.
Arguments VarSet i {T} v.

Definition varmem := @mem vartype vartype_eq_dec var_value.

Inductive outcome (T : Type) :=
  | Failed
  | Finished (m: rawdisk) (v: varmem) (hm: hashmap) (v: T)
  | Crashed (m: rawdisk) (hm: hashmap).

Inductive step : forall T,
    rawdisk -> varmem -> hashmap -> prog T ->
    rawdisk -> varmem -> hashmap -> T -> Prop :=
| StepRead : forall m a v x vm hm,
    m a = Some (v, x) ->
    step m vm hm (Read a) m vm hm v
| StepWrite : forall m a v v0 x vm hm,
    m a = Some (v0, x) ->
    step m vm hm (Write a v) (upd m a (v, v0 :: x)) vm hm tt
| StepSync : forall m vm hm,
    step m vm hm (Sync) (sync_mem m) vm hm tt
| StepTrim : forall m a vs vs' vm hm,
    m a = Some vs ->
    step m vm hm (Trim a) (upd m a vs') vm hm tt
| StepHash : forall m sz (buf : word sz) h vm hm,
    hash_safe hm h buf ->
    hash_fwd buf = h ->
    step m vm hm (Hash buf) m vm (upd_hashmap' hm h buf) h
| StepHash2 : forall m sz1 sz2 (buf1 : word sz1) (buf2 : word sz2) (buf : word (sz1 + sz2)) h vm hm,
    buf = Word.combine buf1 buf2 ->
    hash_safe hm h buf ->
    hash_fwd buf = h ->
    step m vm hm (Hash2 buf1 buf2) m vm (upd_hashmap' hm h buf) h
| StepVarAlloc : forall T d v vm i hm,
    vm i = None ->
    step d vm hm (@VarAlloc T v) d (insert vm i (@Any T v)) hm i
| StepVarDelete : forall d v vm i hm,
    vm i = Some v ->
    step d vm hm (VarDelete i) d (delete vm i) hm tt
| StepVarGet : forall T d v vm i hm,
    vm i = Some (@Any T v) ->
    step d vm hm (@VarGet i T) d vm hm v
| StepVarSet : forall T d v0 v vm i hm,
    vm i = Some v0 ->
    step d vm hm (@VarSet i T v) d (upd vm i (@Any T v)) hm tt.

Inductive fail_step : forall T,
    rawdisk -> varmem -> prog T -> Prop :=
| FailRead : forall m vm a,
    m a = None ->
    fail_step m vm (Read a)
| FailWrite : forall m vm a v,
    m a = None ->
    fail_step m vm (Write a v)
| FailTrim : forall m vm a,
    m a = None ->
    fail_step m vm (Trim a)
| FailVarDelete : forall m vm i,
    vm i = None ->
    fail_step m vm (VarDelete i)
| FailVarGetType : forall T T' m vm i (v : T'),
    T <> T' ->
    vm i = Some (Any v) ->
    fail_step m vm (@VarGet i T)
| FailVarGetNone : forall T m vm i,
    vm i = None ->
    fail_step m vm (@VarGet i T)
| FailVarSetNone : forall T m vm i (v : T),
    vm i = None ->
    fail_step m vm (VarSet i v).

Inductive crash_step : forall T, prog T -> Prop :=
| CrashRead : forall a,
    crash_step (Read a)
| CrashWrite : forall a v,
    crash_step (Write a v)
| CrashSync :
    crash_step Sync.

Inductive exec : forall T, rawdisk -> varmem -> hashmap -> prog T -> outcome T -> Prop :=
| XRet : forall T m vm hm (v: T),
    exec m vm hm (Ret v) (Finished m vm hm v)
| XAlertModified : forall m vm hm,
    exec m vm hm (AlertModified) (Finished m vm hm tt)
| XDebug : forall m vm hm s a,
    exec m vm hm (Debug s a) (Finished m vm hm tt)
| XRdtsc : forall m vm hm t,
    exec m vm hm (Rdtsc) (Finished m vm hm t)
| XStep : forall T m vm hm (p: prog T) m' m'' vm' hm' v,
    step m vm hm p m' vm' hm' v ->
    possible_sync m' m'' ->
    exec m vm hm p (Finished m'' vm' hm' v)
| XBindFinish : forall m vm hm T (p1: prog T) m' vm' hm' (v: T)
                  T' (p2: T -> prog T') out,
    exec m vm hm p1 (Finished m' vm' hm' v) ->
    exec m' vm' hm' (p2 v) out ->
    exec m vm hm (Bind p1 p2) out
| XBindFail : forall m vm hm T (p1: prog T)
                T' (p2: T -> prog T'),
    exec m vm hm p1 (Failed T) ->
    exec m vm hm (Bind p1 p2) (Failed T')
| XBindCrash : forall m vm hm T (p1: prog T) m' hm'
                 T' (p2: T -> prog T'),
    exec m vm hm p1 (Crashed T m' hm') ->
    exec m vm hm (Bind p1 p2) (Crashed T' m' hm')
| XFail : forall m vm hm T (p: prog T),
    fail_step m vm p ->
    exec m vm hm p (Failed T)
| XCrash : forall m vm hm T (p: prog T),
    crash_step p ->
    exec m vm hm p (Crashed T m hm).

(** program with recovery *)
Inductive recover_outcome (TF TR: Type) :=
  | RFailed
  | RFinished (m: rawdisk) (vm: varmem) (hm: hashmap) (v: TF)
  | RRecovered (m: rawdisk) (vm: varmem) (hm: hashmap) (v: TR).

Inductive exec_recover (TF TR: Type)
    : rawdisk -> varmem -> hashmap -> prog TF -> prog TR -> recover_outcome TF TR -> Prop :=
  | XRFail : forall m vm hm p1 p2, exec m vm hm p1 (Failed TF)
    -> exec_recover m vm hm p1 p2 (RFailed TF TR)
  | XRFinished : forall m vm hm p1 p2 m' vm' hm' (v: TF), exec m vm hm p1 (Finished m' vm' hm' v)
    -> exec_recover m vm hm p1 p2 (RFinished TR m' vm' hm' v)
  | XRCrashedFailed : forall m vm hm p1 p2 m' hm' m'r, exec m vm hm p1 (Crashed TF m' hm')
    -> possible_crash m' m'r
    -> @exec_recover TR TR m'r empty_mem hm' p2 p2 (RFailed TR TR)
    -> exec_recover m vm hm p1 p2 (RFailed TF TR)
  | XRCrashedFinished : forall m vm hm p1 p2 m' hm' m'r m'' vm'' hm'' (v: TR), exec m vm hm p1 (Crashed TF m' hm')
    -> possible_crash m' m'r
    -> @exec_recover TR TR m'r empty_mem hm' p2 p2 (RFinished TR m'' vm'' hm'' v)
    -> exec_recover m vm hm p1 p2 (RRecovered TF m'' vm'' hm'' v)
  | XRCrashedRecovered : forall m vm hm p1 p2 m' hm' m'r m'' vm'' hm'' (v: TR), exec m vm hm p1 (Crashed TF m' hm')
    -> possible_crash m' m'r
    -> @exec_recover TR TR m'r empty_mem hm' p2 p2 (RRecovered TR m'' vm'' hm'' v)
    -> exec_recover m vm hm p1 p2 (RRecovered TF m'' vm'' hm'' v).

Hint Constructors exec.
Hint Constructors step.
Hint Constructors exec_recover.

(** program notations *)

Definition pair_args_helper (A B C:Type) (f: A->B->C) (x: A*B) := f (fst x) (snd x).
Notation "^( a )" := (pair a tt).
Notation "^( a , .. , b )" := (pair a .. (pair b tt) .. ).

Notation "p1 ;; p2" := (Bind p1 (fun _: unit => p2)) (at level 60, right associativity).
Notation "x <- p1 ; p2" := (Bind p1 (fun x => p2)) (at level 60, right associativity,
                                                 format "'[v' x  <-  p1 ; '/' p2 ']'").
Notation "'let^' ( a ) <- p1 ; p2" :=
  (Bind p1
    (pair_args_helper (fun a (_:unit) => p2))
  )
  (at level 60, right associativity, a ident,
   format "'[v' let^ ( a )  <-  p1 ; '/' p2 ']'").

Notation "'let^' ( a , .. , b ) <- p1 ; p2" :=
  (Bind p1
    (pair_args_helper (fun a => ..
      (pair_args_helper (fun b (_:unit) => p2))
    ..))
  )
    (at level 60, right associativity, a closed binder, b closed binder,
     format "'[v' let^ ( a , .. , b )  <-  p1 ; '/' p2 ']'").


Require Import Events.
Require Import ValuesC.
Require Import AST.
Require Import Memory.
Require Import Globalenvs.
Require Import Smallstep.
Require Import CoqlibC.
Require Import Skeleton.
Require Import Integers.
Require Import ASTC.
Require Import LinkingC.
Require Import Maps.

Require Import SimMem.
Require Import System.
Require Import ModSem.

Set Implicit Arguments.

Module SimSymb.

  Inductive skenv_func_bisim (sim_val: val -> val -> Prop) (skenv_src skenv_tgt: SkEnv.t): Prop :=
  | skenv_func_bisim_intro
      (FUNCFSIM: forall fptr_src fptr_tgt def_src
          (SIMFPTR: sim_val fptr_src fptr_tgt)
          (FUNCSRC: (Genv.find_funct skenv_src) fptr_src = Some def_src),
          exists def_tgt, <<FUNCSRC: (Genv.find_funct skenv_tgt) fptr_tgt = Some def_tgt>> /\ <<SIM: def_src = def_tgt>>).

  Class class (SM: SimMem.class) :=
    { t: Type;
      le: t -> t -> Prop;
      src: t -> Sk.t;
      tgt: t -> Sk.t;

      le_PreOrder :> PreOrder le;

      wf: t -> Prop;
      wf_preserves_wf: forall ss0
          (SIMSK: wf ss0)
          (WFSRC: Sk.wf ss0.(src)),
          <<WFTGT: Sk.wf ss0.(tgt)>>;

      wf_link: forall ss0 ss1 sk_src
          (SIMSK: wf ss0)
          (SIMSK: wf ss1)
          (LINKSRC: link ss0.(src) ss1.(src) = Some sk_src)
          (WFSRC0: Sk.wf ss0.(src))
          (WFSRC1: Sk.wf ss1.(src))
          (WFTGT0: Sk.wf ss0.(tgt))
          (WFTGT1: Sk.wf ss1.(tgt)),
          exists ss sk_tgt,
            <<LINKTGT: link ss0.(tgt) ss1.(tgt) = Some sk_tgt>> /\
            <<SKSRC: ss.(src) = sk_src>> /\
            <<SKTGT: ss.(tgt) = sk_tgt>> /\
            <<LE0: le ss0 ss>> /\
            <<LE1: le ss1 ss>> /\
            <<SIMSK: wf ss>>;

      sim_skenv: SimMem.t -> t -> SkEnv.t -> SkEnv.t -> Prop;

      sim_skenv_public_symbols: forall sm0 ss0 skenv_src skenv_tgt
          (SIMSKE: sim_skenv sm0 ss0 skenv_src skenv_tgt),
          (Genv.public_symbol skenv_src) = (Genv.public_symbol skenv_tgt);

      wf_load_sim_skenv: forall ss skenv_src skenv_tgt m_src
          (SIMSK: wf ss)
          (LOADSRC: (Sk.load_skenv ss.(src)) = skenv_src)
          (LOADTGT: (Sk.load_skenv ss.(tgt)) = skenv_tgt)
          (LOADMEMSRC: (Sk.load_mem ss.(src)) = Some m_src),
          exists m_tgt sm,
            (<<LOADMEMTGT: (Sk.load_mem ss.(tgt)) = Some m_tgt>>) /\
            (<<SIMSKENV: sim_skenv sm ss skenv_src skenv_tgt>>) /\
            (<<MEMSRC: sm.(SimMem.src) = m_src>>) /\
            (<<MEMTGT: sm.(SimMem.tgt) = m_tgt>>) /\
            (<<MWF: sm.(SimMem.wf)>>) /\
            (<<MAINSIM: SimMem.sim_val sm (Genv.symbol_address skenv_src ss.(src).(prog_main) Ptrofs.zero)
                                       (Genv.symbol_address skenv_tgt ss.(tgt).(prog_main) Ptrofs.zero)>>);

      mlepriv_preserves_sim_skenv: forall sm0 sm1 ss skenv_src skenv_tgt
          (MLE: SimMem.lepriv sm0 sm1)
          (SIMSKENV: sim_skenv sm0 ss skenv_src skenv_tgt),
          <<SIMSKENV: sim_skenv sm1 ss skenv_src skenv_tgt>>;

      sim_skenv_monotone: forall
          sm ss_link skenv_link_src skenv_link_tgt
          ss skenv_src skenv_tgt
          (WFSRC: SkEnv.wf skenv_link_src)
          (WFTGT: SkEnv.wf skenv_link_tgt)
          (SIMSKENV: sim_skenv sm ss_link skenv_link_src skenv_link_tgt)
          (SIMSK: wf ss)
          (LE: le ss ss_link)
          (INCLSRC: SkEnv.includes skenv_link_src ss.(src))
          (INCLTGT: SkEnv.includes skenv_link_tgt ss.(tgt))
          (LESRC: SkEnv.project skenv_link_src ss.(src) = skenv_src)
          (LETGT: SkEnv.project skenv_link_tgt ss.(tgt) = skenv_tgt),
          <<SIMSKENV: sim_skenv sm ss skenv_src skenv_tgt>>;

      sim_skenv_func_bisim: forall sm ss skenv_src skenv_tgt
          (SIMSKENV: sim_skenv sm ss skenv_src skenv_tgt),
          <<DEF: skenv_func_bisim sm.(SimMem.sim_val) skenv_src skenv_tgt>>;

      system_sim_skenv: forall sm ss skenv_src skenv_tgt
          (SIMSKENV: sim_skenv sm ss skenv_src skenv_tgt),
          <<SIMSKENV: sim_skenv sm ss (System.skenv skenv_src) (System.skenv skenv_tgt)>>;
      system_axiom: forall
          sm0 ss_sys skenv_sys_src skenv_sys_tgt
          args_src args_tgt tr retv_src ef
          (SIMSKENV: sim_skenv sm0 ss_sys skenv_sys_src skenv_sys_tgt)
          (MWF: SimMem.wf sm0)
          (CSTYLE: Args.is_cstyle args_src)
          (CSTYLE: Retv.is_cstyle retv_src)
          (ARGS: SimMem.sim_args args_src args_tgt sm0)
          (SYSSRC: external_call ef skenv_sys_src (Args.vs (args_src)) (Args.m (args_src))
                                 tr
                                 (Retv.v (retv_src)) (Retv.m (retv_src))),
          exists sm1 retv_tgt,
            (<<SYSTGT: external_call ef skenv_sys_tgt (Args.vs (args_tgt)) (Args.m (args_tgt))
                                     tr
                                     (Retv.v (retv_tgt)) (Retv.m (retv_tgt))>>)
            /\ (<<RETV: SimMem.sim_retv retv_src retv_tgt sm1>>)
            /\ (<<MLE0: SimMem.le sm0 sm1>>)
            /\ (<<MWF: SimMem.wf sm1>>);
    }.

  Lemma mle_preserves_sim_skenv: forall
      `{SM: SimMem.class} `{SS: @class SM}
      sm0 sm1 ss skenv_src skenv_tgt
      (MLE: SimMem.le sm0 sm1)
      (SIMSKENV: sim_skenv sm0 ss skenv_src skenv_tgt),
      <<SIMSKENV: sim_skenv sm1 ss skenv_src skenv_tgt>>.
  Proof. ii. eapply mlepriv_preserves_sim_skenv; et. Qed.

  Lemma mfuture_preserves_sim_skenv
        `{SM: SimMem.class} `{SS: @class SM}
        sm0 sm1 ss skenv_src skenv_tgt
        (MFUTURE: SimMem.future sm0 sm1)
        (SIMSKENV: sim_skenv sm0 ss skenv_src skenv_tgt):
      <<SIMSKENV: sim_skenv sm1 ss skenv_src skenv_tgt>>.
  Proof.
    induction MFUTURE; ss. des.
    - eapply IHMFUTURE; eauto. eapply mlepriv_preserves_sim_skenv; eauto.
    - eapply IHMFUTURE; eauto. eapply mle_preserves_sim_skenv; eauto.
  Qed.

  Lemma simskenv_func_fsim
        `{SM: SimMem.class} `{SS: @class SM}
        ss0 sm0 skd v_src v_tgt skenv_link_src skenv_link_tgt
        (SIMSKENV: sim_skenv sm0 ss0 skenv_link_src skenv_link_tgt)
        (SIMV: sm0.(SimMem.sim_val) v_src v_tgt)
        (FIND: Genv.find_funct skenv_link_src v_src = Some skd):
      Genv.find_funct skenv_link_tgt v_tgt = Some skd.
  Proof. exploit SimSymb.sim_skenv_func_bisim; eauto. i; des. inv H. exploit FUNCFSIM; eauto. i; des. clarify. Qed.

End SimSymb.


From mathcomp
Require Import ssreflect ssrbool ssrnat eqtype seq ssrfun.
From fcsl
Require Import prelude pred pcm unionmap heap.
From HTT
Require Import stmod stsep stlog stlogR.
From SSL
Require Import core.
From Hammer Require Import Hammer.
(* Configure Hammer *)
Set Hammer ATPLimit 60.
Unset Hammer Eprover.
Unset Hammer Vampire.
Add Search Blacklist "fcsl.".
Add Search Blacklist "HTT.".
Add Search Blacklist "Coq.ssr.ssrfun".
Add Search Blacklist "mathcomp.ssreflect.ssrfun".
Add Search Blacklist "mathcomp.ssreflect.bigop".
Add Search Blacklist "mathcomp.ssreflect.choice".
Add Search Blacklist "mathcomp.ssreflect.div".
Add Search Blacklist "mathcomp.ssreflect.finfun".
Add Search Blacklist "mathcomp.ssreflect.fintype".
Add Search Blacklist "mathcomp.ssreflect.path".
Add Search Blacklist "mathcomp.ssreflect.tuple".

Require Import common.

Lemma pure1 : (0) = (0). intros; hammer. Qed.
Hint Resolve pure1: ssl_pure.
Lemma pure2 (n1x1 : nat) (n2x1 : nat) : (0) <= (((1) + (n1x1)) + (n2x1)) -> (0) <= (n1x1) -> (0) <= (n2x1) -> (((1) + (n1x1)) + (n2x1)) = (((1) + (n1x1)) + (n2x1)). intros; hammer. Qed.
Hint Resolve pure2: ssl_pure.

Definition tree_size_type :=
  forall (vprogs : ptr * ptr),
  {(vghosts : nat)},
  STsep (
    fun h =>
      let: (x, r) := vprogs in
      let: (n) := vghosts in
      exists h_treeN_xn_a,
      (0) <= (n) /\ h = r :-> (0) \+ h_treeN_xn_a /\ treeN x n h_treeN_xn_a,
    [vfun (_: unit) h =>
      let: (x, r) := vprogs in
      let: (n) := vghosts in
      exists h_treeN_xn_a,
      h = r :-> (n) \+ h_treeN_xn_a /\ treeN x n h_treeN_xn_a
    ]).

Program Definition tree_size : tree_size_type :=
  Fix (fun (tree_size : tree_size_type) vprogs =>
    let: (x, r) := vprogs in
    Do (
      if (x) == (null)
      then
        ret tt
      else
        vx1 <-- @read ptr x;
        lx1 <-- @read ptr (x .+ 1);
        rx1 <-- @read ptr (x .+ 2);
        tree_size (lx1, r);;
        n1x1 <-- @read nat r;
        r ::= 0;;
        tree_size (rx1, r);;
        n2x1 <-- @read nat r;
        r ::= ((1) + (n1x1)) + (n2x1);;
        ret tt
    )).
Obligation Tactic := intro; move=>[x r]; ssl_program_simpl.
Next Obligation.
ssl_ghostelim_pre.
move=>n.
ex_elim h_treeN_xn_a.
move=>[phi_self0].
move=>[sigma_self].
subst h_self.
move=>H_treeN_xn_a.
ssl_ghostelim_post.
ssl_open ((x) == (null)) H_treeN_xn_a.
move=>[phi_treeN_xn_a0].
move=>[sigma_treeN_xn_a].
subst h_treeN_xn_a.
try rename h_treeN_xn_a into h_treeN_x_a.
try rename H_treeN_xn_a into H_treeN_x_a.
ssl_emp;
exists (empty);
sslauto.
ssl_close 1;
sslauto.
ex_elim n1x n2x lx rx vx.
ex_elim h_treeN_lxn1x_2x h_treeN_rxn2x_3x.
move=>[phi_treeN_xn_a0] [phi_treeN_xn_a1] [phi_treeN_xn_a2].
move=>[sigma_treeN_xn_a].
subst h_treeN_xn_a.
move=>[H_treeN_lxn1x_2x H_treeN_rxn2x_3x].
try rename h_treeN_xn_a into h_treeN_xn1xn2x_a.
try rename H_treeN_xn_a into H_treeN_xn1xn2x_a.
ssl_read x.
try rename vx into vx1.
ssl_read (x .+ 1).
try rename lx into lx1.
try rename h_treeN_lxn1x_2x into h_treeN_lx1n1x_2x.
try rename H_treeN_lxn1x_2x into H_treeN_lx1n1x_2x.
ssl_read (x .+ 2).
try rename rx into rx1.
try rename h_treeN_rxn2x_3x into h_treeN_rx1n2x_3x.
try rename H_treeN_rxn2x_3x into H_treeN_rx1n2x_3x.
try rename h_treeN_x1n1_a1 into h_treeN_lx1n1x_2x.
try rename H_treeN_x1n1_a1 into H_treeN_lx1n1x_2x.
ssl_call_pre (r :-> (0) \+ h_treeN_lx1n1x_2x).
ssl_call (n1x).
exists (h_treeN_lx1n1x_2x);
sslauto.
ssl_frame_unfold.
move=>h_call0.
ex_elim h_treeN_lx1n1x_2x.
move=>[sigma_call0].
subst h_call0.
move=>H_treeN_lx1n1x_2x.
store_valid.
ssl_read r.
try rename n1x into n1x1.
try rename h_treeN_lx1n1x_2x into h_treeN_lx1n1x1_2x.
try rename H_treeN_lx1n1x_2x into H_treeN_lx1n1x1_2x.
try rename h_treeN_xn1xn2x_a into h_treeN_xn1x1n2x_a.
try rename H_treeN_xn1xn2x_a into H_treeN_xn1x1n2x_a.
try rename h_treeN_x2n2_a2 into h_treeN_rx1n2x_3x.
try rename H_treeN_x2n2_a2 into H_treeN_rx1n2x_3x.
ssl_write r.
ssl_call_pre (r :-> (0) \+ h_treeN_rx1n2x_3x).
ssl_call (n2x).
exists (h_treeN_rx1n2x_3x);
sslauto.
ssl_frame_unfold.
move=>h_call1.
ex_elim h_treeN_rx1n2x_3x.
move=>[sigma_call1].
subst h_call1.
move=>H_treeN_rx1n2x_3x.
store_valid.
ssl_read r.
try rename n2x into n2x1.
try rename h_treeN_xn1x1n2x_a into h_treeN_xn1x1n2x1_a.
try rename H_treeN_xn1x1n2x_a into H_treeN_xn1x1n2x1_a.
try rename h_treeN_rx1n2x_3x into h_treeN_rx1n2x1_3x.
try rename H_treeN_rx1n2x_3x into H_treeN_rx1n2x1_3x.
try rename h_treeN_lx2n11x_2x1 into h_treeN_lx1n1x1_2x.
try rename H_treeN_lx2n11x_2x1 into H_treeN_lx1n1x1_2x.
try rename h_treeN_r3xn21x_3x1 into h_treeN_rx1n2x1_3x.
try rename H_treeN_r3xn21x_3x1 into H_treeN_rx1n2x1_3x.
ssl_write r.
ssl_write_post r.
ssl_emp;
exists (x :-> (vx1) \+ x .+ 1 :-> (lx1) \+ x .+ 2 :-> (rx1) \+ h_treeN_lx1n1x1_2x \+ h_treeN_rx1n2x1_3x);
sslauto.
ssl_close 2;
exists (n1x1), (n2x1), (lx1), (rx1), (vx1), (h_treeN_lx1n1x1_2x), (h_treeN_rx1n2x1_3x);
sslauto.
ssl_frame_unfold.
ssl_frame_unfold.
Qed.


From VLSM.Lib Require Import Itauto.
From stdpp Require Import prelude finite.
From Coq Require Import FinFun Reals Lra.
From VLSM.Lib Require Import Preamble Measurable RealsExtras FinSetExtras.
From VLSM.Core Require Import VLSM VLSMProjections Composition AnnotatedVLSM.
From VLSM.Core Require Import Equivocation Equivocation.TraceWiseEquivocation MessageDependencies.
From VLSM.Core Require Import Equivocation.NoEquivocation Equivocation.LimitedMessageEquivocation.
From VLSM.Core Require Import FixedSetEquivocation MsgDepLimitedEquivocation.
From VLSM.Core Require Import Equivocators.Equivocators.
From VLSM.Core Require Import Equivocators.MessageProperties.
From VLSM.Core Require Import Equivocators.EquivocatorsComposition.
From VLSM.Core Require Import Equivocators.EquivocatorsCompositionProjections.
From VLSM.Core Require Import Equivocators.FixedEquivocation.

(** * VLSM Limited Equivocation *)
Definition composite_constraint
  {index message} (IM : index -> VLSM message) : Type :=
  composite_label IM -> composite_state IM * option message -> Prop.

Lemma equivocator_initial_state_project
  {message}
  (X : VLSM message)
  (es : vstate (equivocator_vlsm X))
  (eqv_descriptor : MachineDescriptor X)
  (Heqv : proper_descriptor X eqv_descriptor es)
  (Hes : vinitial_state_prop (equivocator_vlsm X) es) :
  vinitial_state_prop X (equivocator_state_descriptor_project es eqv_descriptor).
Proof.
  destruct eqv_descriptor; [done |].
  destruct Heqv as [esn Hesn].
  simpl. rewrite Hesn.
  by eapply equivocator_vlsm_initial_state_preservation_rev.
Qed.

Lemma composite_equivocators_initial_state_project
  {message}
  `{EqDecision index}
  (IM : index -> VLSM message)
  (es : composite_state (equivocator_IM IM))
  (eqv_descriptors : equivocator_descriptors IM)
  {eqv_constraint : composite_constraint (equivocator_IM IM)}
  {constraint : composite_constraint IM}
  (Heqv : proper_equivocator_descriptors IM eqv_descriptors es)
  (Hes : vinitial_state_prop (composite_vlsm (equivocator_IM IM) eqv_constraint) es)
  : vinitial_state_prop (composite_vlsm IM constraint)
      (equivocators_state_project IM eqv_descriptors es).
Proof.
  refine (fun i => equivocator_initial_state_project _ _ _ (Heqv i) (Hes i)).
Qed.

Section sec_limited_state_equivocation.

Context {message index : Type}
  (IM : index -> VLSM message)
  `{forall i : index, HasBeenSentCapability (IM i)}
  `{forall i : index, HasBeenReceivedCapability (IM i)}
  (threshold : R)
  `{ReachableThreshold index Ci threshold}
  `{!finite.Finite index}
  (Free := free_composite_vlsm IM)
  (equivocator_descriptors := equivocator_descriptors IM)
  (equivocators_state_project := equivocators_state_project IM)
  (equivocator_IM := equivocator_IM IM)
  (equivocator_descriptors_update := equivocator_descriptors_update IM)
  (proper_equivocator_descriptors := proper_equivocator_descriptors IM)
  (sender : message -> option index)
  (Heqv_idx_BasicEquivocation : BasicEquivocation (composite_state equivocator_IM) index Ci threshold
    := equivocating_indices_BasicEquivocation IM threshold)
  (FreeE : VLSM message := free_composite_vlsm equivocator_IM)
  (PreFreeE := pre_loaded_with_all_messages_vlsm FreeE)
  (not_heavy := not_heavy (1 := Heqv_idx_BasicEquivocation))
  (equivocating_validators := equivocating_validators (1 := Heqv_idx_BasicEquivocation))
  (equivocation_fault := equivocation_fault (1 := Heqv_idx_BasicEquivocation))
  .

Definition equivocators_limited_equivocations_constraint
  (l : composite_label equivocator_IM)
  (som : composite_state equivocator_IM * option message)
  (som' := composite_transition equivocator_IM l som)
  : Prop
  := equivocators_no_equivocations_constraint IM l som
  /\ not_heavy (fst som').

Definition equivocators_limited_equivocations_vlsm
  : VLSM message
  :=
  composite_vlsm equivocator_IM equivocators_limited_equivocations_constraint.

(** Inclusion in the free composition. *)
Lemma equivocators_limited_equivocations_vlsm_incl_free
  : VLSM_incl equivocators_limited_equivocations_vlsm FreeE.
Proof.
  by apply constraint_subsumption_incl.
Qed.

(** Inclusion in the preloaded free composition. *)
Lemma equivocators_limited_equivocations_vlsm_incl_preloaded_free
  : VLSM_incl equivocators_limited_equivocations_vlsm PreFreeE.
Proof.
  specialize equivocators_limited_equivocations_vlsm_incl_free as Hincl1.
  specialize (vlsm_incl_pre_loaded_with_all_messages_vlsm FreeE)
    as Hincl2.
  by eapply VLSM_incl_trans.
Qed.

(** Inclusion of preloaded machine in the preloaded free composition. *)
Lemma preloaded_equivocators_limited_equivocations_vlsm_incl_free
  : VLSM_incl (pre_loaded_with_all_messages_vlsm equivocators_limited_equivocations_vlsm) PreFreeE.
Proof.
  by apply basic_VLSM_incl_preloaded; intros ? *; [intro | inversion 1 | intro].
Qed.

(**
  Inclusion in the composition of equivocators with no message equivocation
  (no restriction on state equivocation).
*)
Lemma equivocators_limited_equivocations_vlsm_incl_no_equivocations
  : VLSM_incl equivocators_limited_equivocations_vlsm (equivocators_no_equivocations_vlsm IM).
Proof.
  apply constraint_subsumption_incl.
  by intros l [s om] (_ & _ & _ & Hc & _).
Qed.

(**
  A valid state for a VLSM satisfying the limited equivocation assumption
  has limited equivocation.
*)
Lemma valid_state_limited_equivocation
  (s : composite_state equivocator_IM)
  (Hs : valid_state_prop equivocators_limited_equivocations_vlsm s)
  : not_heavy s.
Proof.
  apply valid_state_prop_iff in Hs.
  destruct Hs as [[(is, His) Heq_s] | [l [(s0, oim) [oom' [[_ [_ [_ [_ Hlimited]]]] Ht]]]]].
  - subst s.
    unfold not_heavy, Equivocation.not_heavy,
      equivocation_fault, Equivocation.equivocation_fault; simpl.
    pose proof (Heqv_is := @equivocating_indices_equivocating_validators _ _ _ _
        IM _ _ _ H1 _ _ _ _ _ _ _ _ H9 is).
    rewrite equivocating_indices_initially_empty in Heqv_is by done.
    simpl in Heqv_is; apply sum_weights_empty in Heqv_is.
    pose proof (rt_positive (H6 := H8)).
    by cbv in Heqv_is |- *; lra.
  - by replace s with (fst (composite_transition equivocator_IM l (s0, oim))); [done |]
    ; cbn in *; rewrite Ht.
Qed.

(**
  A valid valid trace for the composition of equivocators with limited
  state-equivocation and no message-equivocation is also a valid valid trace
  for the composition of equivocators with no message-equivocation and fixed-set
  state-equivocation, where the fixed set is given by the state-equivocators
  measured for the final state of the trace.
*)
Lemma equivocators_limited_valid_trace_is_fixed is s tr
  : finite_valid_trace_init_to equivocators_limited_equivocations_vlsm is s tr ->
  finite_valid_trace_init_to
   (equivocators_fixed_equivocations_vlsm IM (elements(equivocating_validators s)))
   is s tr.
Proof.
  intro Htr.
  split; [| apply Htr].
  cut
    (forall equivocating, elements(equivocating_validators s) ⊆ equivocating ->
      finite_valid_trace_from_to (equivocators_fixed_equivocations_vlsm IM equivocating) is s tr);
    [by intros H'; apply H' |].
  induction Htr using finite_valid_trace_init_to_rev_ind; intros equivocating Hincl.
  - apply (finite_valid_trace_from_to_empty (equivocators_fixed_equivocations_vlsm IM equivocating)).
    by apply initial_state_is_valid.
  - specialize (IHHtr equivocating).
    spec IHHtr.
    { apply proj2 in Ht.
      specialize (equivocators_transition_preserves_equivocating_indices
        IM (enum index)  _ _ _ _ _ Ht) as Hincl'.
      clear -Hincl Hincl'.
      transitivity (elements (equivocating_validators sf)); [| done].
      intro x; rewrite! elem_of_elements; intro Hx.
      apply equivocating_indices_equivocating_validators, elem_of_list_to_set, Hincl'.
      by apply equivocating_indices_equivocating_validators, elem_of_list_to_set in Hx.
    }
    apply
      (finite_valid_trace_from_to_app
        (equivocators_fixed_equivocations_vlsm IM equivocating))
      with s; [done |].
    apply valid_trace_add_last; [| done].
      apply (finite_valid_trace_singleton (equivocators_fixed_equivocations_vlsm IM equivocating)).
      apply valid_trace_last_pstate in IHHtr.
      destruct Ht as [[_ [_ [Hv [[Hno_equiv _] Hno_heavy]]]] Ht].
      repeat split; [done | | done | done | | done].
      + destruct iom as [m |]; [| by apply option_valid_message_None].
        destruct Hno_equiv as [Hsent | Hfalse]; [| done].
        simpl in Hsent.
        by eapply composite_sent_valid.
      + replace (composite_transition _ _ _) with (sf, oom).
        unfold state_has_fixed_equivocation.
        transitivity (elements (equivocating_validators sf)); [| done].
        by intros x Hx; apply elem_of_elements, equivocating_indices_equivocating_validators,
          elem_of_list_to_set.
Qed.

(**
  Projections of valid traces for the composition of equivocators
  with limited state-equivocation and no message-equivocation have the
  [fixed_limited_equivocation_prop]erty.
*)
Lemma equivocators_limited_valid_trace_projects_to_fixed_limited_equivocation
  (final_descriptors : equivocator_descriptors)
  (is : composite_state equivocator_IM)
  (tr : list (composite_transition_item equivocator_IM))
  (final_state := finite_trace_last is tr)
  (Hproper : not_equivocating_equivocator_descriptors IM final_descriptors final_state)
  (Htr : finite_valid_trace equivocators_limited_equivocations_vlsm is tr)
  : exists
    (trX : list (composite_transition_item IM))
    (initial_descriptors : equivocator_descriptors)
    (isX := equivocators_state_project initial_descriptors is)
    (final_stateX := finite_trace_last isX trX),
    proper_equivocator_descriptors initial_descriptors is /\
    equivocators_trace_project IM final_descriptors tr = Some (trX, initial_descriptors) /\
    equivocators_state_project final_descriptors final_state = final_stateX /\
    fixed_limited_equivocation_prop (Cv := Ci) (Ci := Ci) IM threshold Datatypes.id isX trX.
Proof.
  apply valid_trace_add_default_last in Htr as Hfixed_tr.
  apply equivocators_limited_valid_trace_is_fixed in Hfixed_tr.
  apply valid_trace_last_pstate in Hfixed_tr as Hfixed_last.
  apply valid_trace_forget_last in Hfixed_tr.
  specialize (fixed_equivocators_valid_trace_project IM
    (equivocating_validators (finite_trace_last is tr)) final_descriptors is tr) as Hpr.
  feed specialize Hpr; [| done |].
  - by eapply not_equivocating_equivocator_descriptors_proper_fixed.
  - destruct Hpr as (trX & initial_descriptors & Hinitial_descriptors & Hpr & Hlst_pr & Hpr_fixed).
    exists trX, initial_descriptors.
    split_and!; [by apply Hinitial_descriptors | done | done |].
    exists (equivocating_validators (finite_trace_last is tr)).
    split.
    + apply valid_trace_add_default_last, valid_trace_last_pstate,
        valid_state_limited_equivocation in Htr.
      transitivity (equivocation_fault (finite_trace_last is tr)); [| done].
      by unfold equivocation_fault; apply sum_weights_subseteq.
    + revert Hpr_fixed.
      apply VLSM_incl_finite_valid_trace, constraint_subsumption_incl.
      apply preloaded_constraint_subsumption_stronger, strong_constraint_subsumption_strongest.
      intros l (s, [m |]); [| done]; cbn.
      intros [| Hemit]; [by left |].
      right; revert Hemit.
      unshelve eapply VLSM_embedding_can_emit, equivocators_composition_for_directly_observed_index_incl_embedding.
      apply elements_subseteq.
      by intros v Hv; apply elem_of_map; eexists.
Qed.

Section sec_equivocators_projection_annotated_limited.

Context
  `{FinSet message Cm}
  (message_dependencies : message -> Cm)
  (full_message_dependencies : message -> Cm)
  (HFullMsgDep : FullMessageDependencies message_dependencies full_message_dependencies)
  (HMsgDep : forall i, MessageDependencies (IM i) message_dependencies)
  (no_initial_messages_in_IM : no_initial_messages_in_IM_prop IM)
  (Hchannel : channel_authentication_prop IM Datatypes.id sender)
  .

(**
  Projections of valid traces for the composition of equivocators
  with limited state-equivocation and no message-equivocation can be
  annotated with equivocators to obtain a limited-message equivocation trace.
*)
Lemma equivocators_limited_valid_trace_projects_to_annotated_limited_equivocation
  (final_descriptors : equivocator_descriptors)
  (is : composite_state equivocator_IM)
  (tr : list (composite_transition_item equivocator_IM))
  (final_state := finite_trace_last is tr)
  (Hproper : not_equivocating_equivocator_descriptors IM final_descriptors final_state)
  (Htr : finite_valid_trace equivocators_limited_equivocations_vlsm is tr)
  : exists
    (trX : list (composite_transition_item IM))
    (initial_descriptors : equivocator_descriptors)
    (isX := equivocators_state_project initial_descriptors is)
    (final_stateX := finite_trace_last isX trX),
    proper_equivocator_descriptors initial_descriptors is /\
    equivocators_trace_project IM final_descriptors tr = Some (trX, initial_descriptors) /\
    equivocators_state_project final_descriptors final_state = final_stateX /\
    finite_valid_trace (msg_dep_limited_equivocation_vlsm IM threshold full_message_dependencies sender (Cv := Ci))
      {| original_state := isX; state_annotation := ` inhabitant |}
      (msg_dep_annotate_trace_with_equivocators IM full_message_dependencies sender isX trX).
Proof.
  eapply equivocators_limited_valid_trace_projects_to_fixed_limited_equivocation
      in Htr as (trX & initial_descriptors & Hinitial_descriptors & Hpr & Hlst_pr & Hpr_limited)
  ; [| done].
  exists trX, initial_descriptors.
  cbn; split_and!; [itauto.. |].
  by eapply @msg_dep_limited_fixed_equivocation; [| | | typeclasses eauto |..].
Qed.

End sec_equivocators_projection_annotated_limited.

Section sec_equivocators_projection_constrained_limited.

Context
  `{FinSet message Cm}
  `{RelDecision _ _ (is_equivocating_tracewise_no_has_been_sent IM Datatypes.id sender)}
  (Limited : VLSM message := tracewise_limited_equivocation_vlsm_composition IM (Cv := Ci) threshold Datatypes.id sender)
  (Hsender_safety : sender_safety_alt_prop IM Datatypes.id sender)
  (message_dependencies : message -> Cm)
  (Hfull : forall i, message_dependencies_full_node_condition_prop (IM i) message_dependencies)
  .

(**
  If each of the nodes satisfy the [message_dependencies_full_node_condition_prop]erty,
  then projections of valid traces for the composition of equivocators
  with limited state-equivocation and no message-equivocation are also valid
  traces for the composition of regular nodes with limited
  message-equivocation.
*)
Lemma limited_equivocators_valid_trace_project
  (final_descriptors : equivocator_descriptors)
  (is : composite_state equivocator_IM)
  (tr : list (composite_transition_item equivocator_IM))
  (final_state := finite_trace_last is tr)
  (Hproper : not_equivocating_equivocator_descriptors IM final_descriptors final_state)
  (Htr : finite_valid_trace equivocators_limited_equivocations_vlsm is tr)
  : exists
    (trX : list (composite_transition_item IM))
    (initial_descriptors : equivocator_descriptors)
    (isX := equivocators_state_project initial_descriptors is)
    (final_stateX := finite_trace_last isX trX),
    proper_equivocator_descriptors initial_descriptors is /\
    equivocators_trace_project IM final_descriptors tr = Some (trX, initial_descriptors) /\
    equivocators_state_project final_descriptors final_state = final_stateX /\
    finite_valid_trace Limited isX trX.
Proof.
  specialize
    (equivocators_limited_valid_trace_projects_to_fixed_limited_equivocation
      final_descriptors is tr Hproper Htr)
      as [trX [initial_descriptors [Hinitial_descriptors [Hpr [Hlst_pr Hpr_limited]]]]].
  exists trX, initial_descriptors.
  repeat split; [done.. | |].
  - by eapply @traces_exhibiting_limited_equivocation_are_valid; [| | typeclasses eauto | |].
  - by destruct Hpr_limited as [equivs Hpr_limited]; apply Hpr_limited.
Qed.

(**
  The above result formalized as a relation between the corresponding
  composite VLSMs. It yields a [VLSM_partial_projection] because for invalid
  [equivocator_descriptors] one might not be able to obtain a trace projection.
*)
Lemma limited_equivocators_vlsm_partial_projection
  (final_descriptors : equivocator_descriptors)
  : VLSM_partial_projection equivocators_limited_equivocations_vlsm Limited
      (equivocators_partial_trace_project IM final_descriptors).
Proof.
  split; [split |].
  - intros s tr sX trX Hpr_tr s_pre pre Hs_lst Hpre_tr.
    assert (HPreFree_pre_tr :
      finite_valid_trace_from (pre_loaded_with_all_messages_vlsm FreeE) s_pre (pre ++ tr)).
    {
      revert Hpre_tr; apply VLSM_incl_finite_valid_trace_from.
      by apply equivocators_limited_equivocations_vlsm_incl_preloaded_free.
    }
    clear Hpre_tr.  revert s tr sX trX Hpr_tr s_pre pre Hs_lst HPreFree_pre_tr.
    by apply equivocators_partial_trace_project_extends_left.
  - intros s tr sX trX Hpr_tr Htr.
    destruct (destruct_equivocators_partial_trace_project IM Hpr_tr)
      as [Hnot_equiv [initial_descriptors [Htr_project Hs_project]]].

    destruct (limited_equivocators_valid_trace_project _ _ _ Hnot_equiv Htr)
      as (_trX & _initial_descriptors & _ & _Htr_project & _ & HtrX).
    rewrite Htr_project in _Htr_project.
    by inversion _Htr_project; subst.
Qed.

(**
  In the case of using the original machine copy for projecting each node, we
  are guaranteed to obtain a trace projection for each trace, hence the relation
  above strengthens to a [VLSM_projection].
*)
Lemma limited_equivocators_vlsm_projection
  : VLSM_projection equivocators_limited_equivocations_vlsm Limited
    (equivocators_total_label_project IM) (equivocators_total_state_project IM).
Proof.
  constructor; [constructor |]; intros ? *.
  - intros HtrX. apply PreFreeE_Free_vlsm_projection_type.
    revert HtrX. apply VLSM_incl_finite_valid_trace_from.
    by apply equivocators_limited_equivocations_vlsm_incl_preloaded_free.
  - intro HtrX.
    assert (Hpre_tr : finite_valid_trace (pre_loaded_with_all_messages_vlsm FreeE) sX trX).
    {
      revert HtrX; apply VLSM_incl_finite_valid_trace.
      by apply equivocators_limited_equivocations_vlsm_incl_preloaded_free.
    }
    specialize (VLSM_partial_projection_finite_valid_trace
      (limited_equivocators_vlsm_partial_projection (zero_descriptor IM))
       sX trX (equivocators_state_project (zero_descriptor IM) sX)
       (equivocators_total_trace_project IM trX))
       as Hsim.
    spec Hsim.
    { simpl. rewrite decide_True by apply zero_descriptor_not_equivocating.
      by rewrite (equivocators_total_trace_project_characterization IM (proj1 Hpre_tr)).
    }
    apply Hsim in HtrX.
    remember (pre_VLSM_projection_finite_trace_project _ _ _ _ _) as tr.
    replace tr with (equivocators_total_trace_project IM trX); [done |].
    subst. symmetry.
    by apply (equivocators_total_VLSM_projection_finite_trace_project IM (proj1 Hpre_tr)).
Qed.

End sec_equivocators_projection_constrained_limited.

End sec_limited_state_equivocation.


Require Import Bool List String Peano_dec Lia.
Require Import Common FMap IndexSupport HVector Syntax Topology Semantics SemFacts StepM.
Require Import Invariant TrsInv Simulation Serial SerialFacts.
Require Import RqRsLang RqRsInvMsg RqRsCorrect.

Require Import Ex.Spec Ex.SpecInds Ex.Template.
Require Import Ex.Mesi Ex.Mesi.Mesi Ex.Mesi.MesiTopo.

Require Import Ex.Mesi.MesiInv Ex.Mesi.MesiInvInv0 Ex.Mesi.MesiInvInv1.

Set Implicit Arguments.

Import PropMonadNotations.
Import CaseNotations.

Local Open Scope list.
Local Open Scope hvec.
Local Open Scope fmap.

#[global] Existing Instance Mesi.ImplOStateIfc.

Definition ObjInvNotOwned (oidx: IdxT) (ost: OState) (msgs: MessagePool Msg) :=
  ObjInvRq oidx msgs -> ost#[owned] = false.

Definition InvNotOwned (st: State): Prop :=
  forall oidx,
    ost <+- (st_oss st)@[oidx]; ObjInvNotOwned oidx ost (st_msgs st).

Section InvNotOwned.
  Variable (tr: tree).
  Hypothesis (Htr: tr <> Node nil).

  Let topo: DTree := fst (tree2Topo tr 0).
  Let cifc: CIfc := snd (tree2Topo tr 0).
  Let impl: System := impl Htr.

  Lemma mesi_InvNotOwned_init:
    Invariant.InvInit impl InvNotOwned.
  Proof.
    do 2 (red; simpl).
    intros.
    destruct (implOStatesInit tr)@[oidx] as [orq|] eqn:Host; simpl; auto.
    red; intros.
    destruct H as [idm [? ?]].
    do 2 red in H; dest_in.
  Qed.

  Lemma mesi_InvNotOwned_ext_in:
    forall oss orqs msgs,
      InvNotOwned {| st_oss := oss; st_orqs := orqs; st_msgs := msgs |} ->
      InObjInds tr 0 {| st_oss := oss; st_orqs := orqs; st_msgs := msgs |} ->
      forall eins,
        ValidMsgsExtIn impl eins ->
        InvNotOwned {| st_oss := oss; st_orqs := orqs; st_msgs := enqMsgs eins msgs |}.
  Proof.
    red; simpl; intros.
    specialize (H oidx); simpl in H.
    destruct (oss@[oidx]) as [ost|] eqn:Host; simpl in *; auto.
    red; intros.
    destruct H2 as [idm [? ?]].
    apply InMP_enqMsgs_or in H2.
    destruct H2; [|apply H; do 2 red; eauto].
    apply in_map with (f:= idOf) in H2; simpl in H2.
    apply H1 in H2; simpl in H2.
    exfalso; eapply DisjList_In_1.
    - apply tree2Topo_minds_merqs_disj.
    - eassumption.
    - eapply tree2Topo_obj_chns_minds_SubList.
      + specialize (H0 oidx); simpl in H0.
        rewrite Host in H0; simpl in H0.
        eassumption.
      + destruct idm as [midx msg]; inv H3.
        simpl; tauto.
  Qed.

  Lemma mesi_InvNotOwned_ext_out:
    forall oss orqs msgs,
      InvNotOwned {| st_oss := oss; st_orqs := orqs; st_msgs := msgs |} ->
      InObjInds tr 0 {| st_oss := oss; st_orqs := orqs; st_msgs := msgs |} ->
      forall (eouts: list (Id Msg)),
        InvNotOwned {| st_oss := oss;
                       st_orqs := orqs;
                       st_msgs := deqMsgs (idsOf eouts) msgs |}.
  Proof.
    red; simpl; intros.
    specialize (H oidx); simpl in H.
    destruct (oss@[oidx]) as [ost|] eqn:Host; simpl in *; auto.
    red; intros.
    destruct H1 as [idm [? ?]].
    apply InMP_deqMsgs in H1.
    apply H; do 2 red; eauto.
  Qed.

  Lemma InvNotOwned_no_update:
    forall oss orqs msgs,
      InvNotOwned {| st_oss:= oss; st_orqs:= orqs; st_msgs:= msgs |} ->
      forall oidx (post nost: OState),
        oss@[oidx] = Some post ->
        nost#[owned] = post#[owned] ->
        InvNotOwned {| st_oss:= oss +[oidx <- nost];
                       st_orqs:= orqs; st_msgs:= msgs |}.
  Proof.
    unfold InvNotOwned; simpl; intros.
    mred; simpl; auto.
    specialize (H oidx).
    rewrite H0 in H; simpl in H.
    red; intros.
    simpl; rewrite H1; auto.
  Qed.

  Lemma InvNotOwned_update_status_NoRqI_NoRsI:
    forall oss orqs msgs,
      InvNotOwned {| st_oss:= oss; st_orqs:= orqs; st_msgs:= msgs |} ->
      forall oidx (ost: OState),
        NoRqI oidx msgs ->
        InvNotOwned {| st_oss:= oss +[oidx <- ost];
                       st_orqs:= orqs; st_msgs:= msgs |}.
  Proof.
    unfold InvNotOwned; simpl; intros.
    mred; simpl; auto.
    red; intros.
    exfalso.
    eapply MsgExistsSig_MsgsNotExist_false; [apply H0| |eassumption].
    simpl; tauto.
  Qed.

  Lemma InvNotOwned_enqMP_rq_valid:
    forall oss orqs msgs,
      InvNotOwned {| st_oss:= oss; st_orqs:= orqs; st_msgs:= msgs |} ->
      forall oidx ost midx msg,
        oss@[oidx] = Some ost ->
        ost#[owned] = false ->
        midx = rqUpFrom oidx ->
        msg.(msg_id) = mesiInvRq ->
        InvNotOwned {| st_oss:= oss; st_orqs:= orqs;
                       st_msgs:= enqMP midx msg msgs |}.
  Proof.
    unfold InvNotOwned; simpl; intros.
    destruct (idx_dec oidx0 oidx); subst.
    - specialize (H oidx).
      rewrite H0 in *; simpl in *.
      red; intros; auto.
    - specialize (H oidx0).
      destruct (oss@[oidx0]) as [ost0|]; simpl in *; auto.
      red; intros.
      destruct H2 as [idm [? ?]].
      apply InMP_enqMP_or in H2; destruct H2.
      + dest; inv H4; rewrite H2 in H7; inv H7.
        exfalso; auto.
      + apply H; do 2 red; eauto.
  Qed.

  Lemma InvNotOwned_other_msg_id_enqMP:
    forall oss orqs msgs,
      InvNotOwned {| st_oss:= oss; st_orqs:= orqs; st_msgs:= msgs |} ->
      forall midx msg,
        msg.(msg_id) <> mesiInvRq ->
        InvNotOwned {| st_oss:= oss; st_orqs:= orqs;
                       st_msgs:= enqMP midx msg msgs |}.
  Proof.
    unfold InvNotOwned; simpl; intros.
    specialize (H oidx).
    destruct (oss@[oidx]) as [ost|] eqn:Host; simpl in *; auto.
    red; intros.
    destruct H1 as [idm [? ?]].
    apply InMP_enqMP_or in H1; destruct H1.
    - dest; subst; inv H2; exfalso; auto.
    - apply H; do 2 red; eauto.
  Qed.

  Lemma InvNotOwned_other_msg_id_enqMsgs:
    forall oss orqs msgs,
      InvNotOwned {| st_oss:= oss; st_orqs:= orqs; st_msgs:= msgs |} ->
      forall nmsgs,
        Forall (fun idm => (valOf idm).(msg_id) <> mesiInvWRq /\
                           (valOf idm).(msg_id) <> mesiInvRq /\
                           (valOf idm).(msg_id) <> mesiInvRs) nmsgs ->
        InvNotOwned {| st_oss:= oss; st_orqs:= orqs;
                       st_msgs:= enqMsgs nmsgs msgs |}.
  Proof.
    intros.
    generalize dependent msgs.
    induction nmsgs as [|[nmidx nmsg] nmsgs]; simpl; intros; auto.
    inv H0; dest.
    apply IHnmsgs; auto.
    apply InvNotOwned_other_msg_id_enqMP; assumption.
  Qed.

  Lemma InvNotOwned_deqMP:
    forall oss orqs msgs,
      InvNotOwned {| st_oss:= oss; st_orqs:= orqs; st_msgs:= msgs |} ->
      forall midx,
        InvNotOwned {| st_oss:= oss; st_orqs:= orqs;
                       st_msgs:= deqMP midx msgs |}.
  Proof.
    unfold InvNotOwned; simpl; intros.
    specialize (H oidx).
    destruct (oss@[oidx]) as [ost|] eqn:Host; simpl in *; auto.
    red; intros.
    destruct H0 as [idm [? ?]].
    apply InMP_deqMP in H0.
    apply H; do 2 red; eauto.
  Qed.

  Lemma InvNotOwned_deqMsgs:
    forall oss orqs msgs,
      InvNotOwned {| st_oss:= oss; st_orqs:= orqs; st_msgs:= msgs |} ->
      forall minds,
        InvNotOwned {| st_oss:= oss; st_orqs:= orqs;
                       st_msgs:= deqMsgs minds msgs |}.
  Proof.
    unfold InvNotOwned; simpl; intros.
    specialize (H oidx).
    destruct (oss@[oidx]) as [ost|] eqn:Host; simpl in *; auto.
    red; intros.
    destruct H0 as [idm [? ?]].
    apply InMP_deqMsgs in H0.
    apply H; do 2 red; eauto.
  Qed.

  Ltac simpl_InvNotOwned_enqMP :=
    simpl;
    try match goal with
        | [H: msg_id ?rmsg = _ |- msg_id ?rmsg <> _] => rewrite H
        end;
    discriminate.

  Ltac simpl_InvNotOwned_enqMsgs :=
    let idm := fresh "idm" in
    let Hin := fresh "H" in
    apply Forall_forall; intros idm Hin;
    apply in_map_iff in Hin; dest; subst;
    repeat ssplit; simpl_InvNotOwned_enqMP.

  Ltac simpl_InvNotOwned :=
    repeat
      (first [apply InvNotOwned_other_msg_id_enqMP; [|simpl_InvNotOwned_enqMP..]
             |apply InvNotOwned_other_msg_id_enqMsgs; [|simpl_InvNotOwned_enqMsgs]
             |apply InvNotOwned_deqMP
             |apply InvNotOwned_deqMsgs
             |apply InvNotOwned_update_status_NoRqI_NoRsI; [|assumption..]
             |eapply InvNotOwned_no_update; [|eauto; fail..]
             |assumption]).

  Ltac solve_InvNotOwned :=
    let oidx := fresh "oidx" in
    red; simpl; intros oidx;
    match goal with
    | [Hi: InvNotOwned _ |- _] =>
      specialize (Hi oidx); simpl in Hi;
      mred; simpl;
      let Hinv := fresh "H" in
      intros Hinv;
      specialize (Hi Hinv)
    end;
    simpl in *; try reflexivity; try solve_mesi.

  Lemma mesi_InvNotOwned_step:
    Invariant.InvStep impl step_m InvNotOwned.
  Proof. (* SKIP_PROOF_ON
    red; intros.
    pose proof (footprints_ok
                  (mesi_GoodORqsInit Htr)
                  (mesi_GoodRqRsSys Htr) H) as Hftinv.
    pose proof (mesi_InObjInds H) as Hioi.
    pose proof (mesi_MsgConflictsInv
                  (@mesi_RootChnInv_ok _ Htr) H) as Hpmcf.
    pose proof (MesiDownLockInv_ok H) as Hmdl.
    pose proof (mesi_InvWBDir_ok H) as Hwd.
    inv H1; [assumption
            |apply mesi_InvNotOwned_ext_in; auto
            |apply mesi_InvNotOwned_ext_out; auto
            |].

    simpl in H2; destruct H2; [subst|apply in_app_or in H1; destruct H1].

    - (*! Cases for the main memory *)

      (** Abstract the root. *)
      assert (In (rootOf (fst (tree2Topo tr 0)))
                 (c_li_indices (snd (tree2Topo tr 0)))) as Hin.
      { rewrite c_li_indices_head_rootOf by assumption.
        left; reflexivity.
      }

      remember (rootOf (fst (tree2Topo tr 0))) as oidx; clear Heqoidx.

      (** Do case analysis per a rule. *)
      apply concat_In in H3; destruct H3 as [crls [? ?]].
      apply in_map_iff in H1; destruct H1 as [cidx [? ?]]; subst.
      dest_in; disc_rule_conds_ex.
      all: try (simpl_InvNotOwned; fail).
      all: try (assert (NoRqI oidx msgs)
                 by (solve_NoRqI_base; solve_NoRqI_by_no_locks oidx);
                simpl_InvNotOwned).

    - (*! Cases for Li caches *)

      (** Derive some necessary information: each Li has a parent. *)
      apply in_map_iff in H1; destruct H1 as [oidx [? ?]]; subst; simpl in *.

      pose proof (tree2Topo_TreeTopoNode tr 0) as Htn.
      pose proof (c_li_indices_tail_has_parent Htr _ _ H2).
      destruct H1 as [pidx [? ?]].
      pose proof (Htn _ _ H4); dest.

      (** Do case analysis per a rule. *)
      apply in_app_or in H3; destruct H3.

      1: { (** Rules per a child *)
        apply concat_In in H3; destruct H3 as [crls [? ?]].
        apply in_map_iff in H3; destruct H3 as [cidx [? ?]]; subst.
        dest_in; disc_rule_conds_ex.

        all: try (simpl_InvNotOwned; fail).
        all: try (assert (NoRqI oidx msgs)
                   by (solve_NoRqI_base; solve_NoRqI_by_no_locks oidx);
                  simpl_InvNotOwned).
      }

      dest_in; disc_rule_conds_ex.

      all: try (simpl_InvNotOwned; fail).
      all: try (derive_footprint_info_basis oidx;
                assert (NoRqI oidx msgs)
                  by (solve_NoRqI_base; solve_NoRqI_by_rsDown oidx);
                simpl_InvNotOwned).
      all: try (simpl_InvNotOwned; solve_InvNotOwned; fail).
      { disc_MesiDownLockInv oidx Hmdl.
        simpl_InvNotOwned; solve_InvNotOwned.
        derive_InvWBDir oidx.
        specialize (Hwd (or_intror (or_introl H24))).
        simpl in Hwd; solve_mesi.
      }
      { eapply InvNotOwned_enqMP_rq_valid; eauto.
        { solve_InvNotOwned. }
        { mred. }
        { assumption. }
      }

    - (*! Cases for L1 caches *)

      (** Derive some necessary information: each Li has a parent. *)
      apply in_map_iff in H1; destruct H1 as [oidx [? ?]]; subst.

      pose proof (tree2Topo_TreeTopoNode tr 0) as Htn.
      pose proof (c_l1_indices_has_parent Htr _ _ H2).
      destruct H1 as [pidx [? ?]].
      pose proof (Htn _ _ H4); dest.

      (** Register an invariant that holds only for L1 caches. *)
      pose proof (mesi_InvL1DirI_ok H) as Hl1d.
      red in Hl1d; simpl in Hl1d.
      rewrite Forall_forall in Hl1d; specialize (Hl1d _ H2).
      simpl in H5; rewrite H5 in Hl1d; simpl in Hl1d.

      (** Do case analysis per a rule. *)
      dest_in; disc_rule_conds_ex.

      all: try (simpl_InvNotOwned; fail).
      all: try (simpl_InvNotOwned; solve_InvNotOwned; fail).
      { derive_footprint_info_basis oidx.
        assert (NoRqI oidx msgs)
          by (solve_NoRqI_base; solve_NoRqI_by_no_locks oidx).
        simpl_InvNotOwned.
      }
      { derive_footprint_info_basis oidx.
        assert (NoRqI oidx msgs)
          by (solve_NoRqI_base; solve_NoRqI_by_rsDown oidx).
        simpl_InvNotOwned.
      }
      { eapply InvNotOwned_enqMP_rq_valid; eauto.
        { solve_InvNotOwned. }
        { mred. }
        { assumption. }
      }

      END_SKIP_PROOF_ON *) admit.
  Qed.

  Theorem mesi_InvNotOwned_ok:
    InvReachable impl step_m InvNotOwned.
  Proof.
    eapply inv_reachable.
    - typeclasses eauto.
    - apply mesi_InvNotOwned_init.
    - apply mesi_InvNotOwned_step.
  Qed.

End InvNotOwned.

Definition CohRsE (oidx: IdxT) (msgs: MessagePool Msg) (cv: nat) :=
  MsgsP [((downTo oidx, (MRs, mesiRsE)),
          (fun idm => (valOf idm).(msg_value) = cv))] msgs.

Definition ObjCohDirE (ost: OState) :=
  ost#[owned] = false /\
  (mesiS <= ost#[status] \/ ost#[dir].(dir_st) = mesiE).

Definition InvDirE (topo: DTree) (st: State): Prop :=
  forall oidx pidx,
    parentIdxOf topo oidx = Some pidx ->
    ost <+- (st_oss st)@[oidx];
      orq <+- (st_orqs st)@[oidx];
      post <+- (st_oss st)@[pidx];
      porq <+- (st_orqs st)@[pidx];
      (ObjDirE porq post oidx ->
       (CohRsE oidx (st_msgs st) post#[val] /\
        (NoRsME oidx (st_msgs st) ->
         ObjCohDirE ost ->
         post#[val] = ost#[val]))).

Lemma ObjDirE_ObjDirME:
  forall orq ost cidx,
    ObjDirE orq ost cidx -> ObjDirME orq ost cidx.
Proof.
  intros.
  red in H; dest.
  red; repeat split; try assumption; solve_mesi.
Qed.

Section InvDirE.
  Variable (tr: tree).
  Hypothesis (Htr: tr <> Node nil).

  Let topo: DTree := fst (tree2Topo tr 0).
  Let cifc: CIfc := snd (tree2Topo tr 0).
  Let impl: System := impl Htr.

  Lemma mesi_InvDirE_init:
    Invariant.InvInit impl (InvDirE topo).
  Proof.
    do 2 (red; simpl); intros.
    destruct (implOStatesInit tr)@[oidx] as [ost|] eqn:Host; simpl; auto.
    destruct (implORqsInit tr)@[oidx] as [orq|] eqn:Horq; simpl; auto.
    destruct (implOStatesInit tr)@[pidx] as [post|] eqn:Hpost; simpl; auto.
    destruct (implORqsInit tr)@[pidx] as [porq|] eqn:Hporq; simpl; auto.
    intros; exfalso.
    red in H0; dest.
    destruct (in_dec idx_dec pidx (c_li_indices cifc ++ c_l1_indices cifc)).
    - subst cifc; rewrite c_li_indices_head_rootOf in i by assumption.
      inv i.
      + rewrite implOStatesInit_value_root in Hpost by assumption.
        inv Hpost.
        simpl in *; solve_mesi.
      + rewrite implOStatesInit_value_non_root in Hpost by assumption.
        inv Hpost.
        simpl in *; solve_mesi.
    - rewrite implOStatesInit_None in Hpost by assumption.
      discriminate.
  Qed.

  Lemma mesi_InvDirE_ext_in:
    forall oss orqs msgs,
      InvDirE topo {| st_oss := oss; st_orqs := orqs; st_msgs := msgs |} ->
      InObjInds tr 0 {| st_oss := oss; st_orqs := orqs; st_msgs := msgs |} ->
      forall eins,
        ValidMsgsExtIn impl eins ->
        InvDirE topo {| st_oss := oss;
                        st_orqs := orqs;
                        st_msgs := enqMsgs eins msgs |}.
  Proof.
    red; simpl; intros.
    specialize (H _ _ H2); simpl in H.
    destruct (oss@[oidx]) as [ost|] eqn:Host; simpl in *; auto.
    destruct (orqs@[oidx]) as [orq|] eqn:Horq; simpl in *; auto.
    destruct (oss@[pidx]) as [post|] eqn:Hpost; simpl in *; auto.
    destruct (orqs@[pidx]) as [porq|] eqn:Hporq; simpl in *; auto.
    intros; specialize (H H3); dest.
    split.
    - apply MsgsP_other_midx_enqMsgs; [assumption|].
      destruct H1; simpl.
      eapply DisjList_SubList; [eassumption|].
      eapply DisjList_comm, DisjList_SubList.
      + eapply SubList_trans;
          [|eapply tree2Topo_obj_chns_minds_SubList with (oidx:= oidx)].
        * solve_SubList.
        * specialize (H0 oidx); simpl in H0.
          rewrite Host in H0; simpl in H0.
          eassumption.
      + apply tree2Topo_minds_merqs_disj.
    - intros; apply MsgsP_enqMsgs_inv in H5; auto.
  Qed.

  Lemma mesi_InvDirE_ext_out:
    forall oss orqs msgs,
      InvDirE topo {| st_oss := oss; st_orqs := orqs; st_msgs := msgs |} ->
      InObjInds tr 0 {| st_oss := oss; st_orqs := orqs; st_msgs := msgs |} ->
      forall (eouts: list (Id Msg)),
        ValidMsgsExtOut impl eouts ->
        InvDirE topo {| st_oss := oss;
                         st_orqs := orqs;
                         st_msgs := deqMsgs (idsOf eouts) msgs |}.
  Proof.
    red; simpl; intros.
    specialize (H _ _ H2); simpl in H.
    destruct (oss@[oidx]) as [ost|] eqn:Host; simpl in *; auto.
    destruct (orqs@[oidx]) as [orq|] eqn:Horq; simpl in *; auto.
    destruct (oss@[pidx]) as [post|] eqn:Hpost; simpl in *; auto.
    destruct (orqs@[pidx]) as [porq|] eqn:Hporq; simpl in *; auto.
    intros; specialize (H H3); dest.
    split.
    - apply MsgsP_deqMsgs; assumption.
    - intros; apply MsgsP_other_midx_deqMsgs_inv in H5; [auto|].
      destruct H1.
      simpl; eapply DisjList_SubList; [eassumption|].
      eapply DisjList_comm, DisjList_SubList.
      + eapply SubList_trans;
          [|eapply tree2Topo_obj_chns_minds_SubList with (oidx:= oidx)].
        * solve_SubList.
        * specialize (H0 oidx); simpl in H0.
          rewrite Host in H0; simpl in H0.
          eassumption.
      + apply tree2Topo_minds_merss_disj.
  Qed.

  Lemma InvDirE_enqMP:
    forall oss orqs msgs,
      InvDirE topo {| st_oss:= oss; st_orqs:= orqs; st_msgs:= msgs |} ->
      forall midx msg,
        msg.(msg_id) <> mesiRsE ->
        InvDirE topo {| st_oss:= oss; st_orqs:= orqs;
                        st_msgs:= enqMP midx msg msgs |}.
  Proof.
    red; simpl; intros.
    specialize (H _ _ H1); simpl in H.
    destruct (oss@[oidx]) as [ost|] eqn:Host; simpl in *; auto.
    destruct (orqs@[oidx]) as [orq|] eqn:Horq; simpl in *; auto.
    destruct (oss@[pidx]) as [post|] eqn:Hpost; simpl in *; auto.
    destruct (orqs@[pidx]) as [porq|] eqn:Hporq; simpl in *; auto.
    intros; specialize (H H2); dest.
    split.
    - apply MsgsP_other_msg_id_enqMP; [assumption|].
      simpl; intro Hx; destruct Hx; auto.
    - intros; apply MsgsP_enqMP_inv in H4; auto.
  Qed.

  Lemma InvDirE_enqMsgs:
    forall oss orqs msgs,
      InvDirE topo {| st_oss:= oss; st_orqs:= orqs; st_msgs:= msgs |} ->
      forall nmsgs,
        Forall (fun idm => (valOf idm).(msg_id) <> mesiRsE) nmsgs ->
        InvDirE topo {| st_oss:= oss; st_orqs:= orqs;
                        st_msgs:= enqMsgs nmsgs msgs |}.
  Proof.
    intros.
    generalize dependent msgs.
    induction nmsgs as [|[nmidx nmsg] nmsgs]; simpl; intros; auto.
    inv H0.
    apply IHnmsgs; auto.
    apply InvDirE_enqMP; assumption.
  Qed.

  Lemma InvDirE_deqMP:
    forall oss orqs msgs,
      InvDirE topo {| st_oss:= oss; st_orqs:= orqs; st_msgs:= msgs |} ->
      forall midx msg,
        FirstMP msgs midx msg ->
        msg.(msg_id) <> mesiRsM ->
        msg.(msg_id) <> mesiRsE ->
        InvDirE topo {| st_oss:= oss; st_orqs:= orqs;
                        st_msgs:= deqMP midx msgs |}.
  Proof.
    unfold InvDirE; simpl; intros.
    specialize (H _ _ H3).
    destruct (oss@[oidx]) as [ost|] eqn:Host; simpl in *; auto.
    destruct (orqs@[oidx]) as [orq|] eqn:Horq; simpl in *; auto.
    destruct (oss@[pidx]) as [post|] eqn:Hpost; simpl in *; auto.
    destruct (orqs@[pidx]) as [porq|] eqn:Hporq; simpl in *; auto.
    intros; specialize (H H4); dest.
    split.
    - apply MsgsP_deqMP; assumption.
    - intros; eapply MsgsP_other_msg_id_deqMP_inv in H6;
        [|eassumption|simpl; intro; intuition].
      auto.
  Qed.

  Lemma InvDirE_deqMsgs:
    forall oss orqs msgs,
      InvDirE topo {| st_oss:= oss; st_orqs:= orqs; st_msgs:= msgs |} ->
      forall rmsgs,
        Forall (FirstMPI msgs) rmsgs ->
        NoDup (idsOf rmsgs) ->
        Forall (fun idm => (valOf idm).(msg_id) <> mesiRsM /\
                           (valOf idm).(msg_id) <> mesiRsE) rmsgs ->
        InvDirE topo {| st_oss:= oss; st_orqs:= orqs;
                        st_msgs:= deqMsgs (idsOf rmsgs) msgs |}.
  Proof.
    unfold InvDirE; simpl; intros.
    specialize (H _ _ H3).
    destruct (oss@[oidx]) as [ost|] eqn:Host; simpl in *; auto.
    destruct (orqs@[oidx]) as [orq|] eqn:Horq; simpl in *; auto.
    destruct (oss@[pidx]) as [post|] eqn:Hpost; simpl in *; auto.
    destruct (orqs@[pidx]) as [porq|] eqn:Hporq; simpl in *; auto.
    intros; specialize (H H4); dest.
    split.
    - apply MsgsP_deqMsgs; assumption.
    - intros; eapply MsgsP_other_msg_id_deqMsgs_inv in H6; try eassumption.
      + specialize (H5 H6 H7); dest; auto.
      + simpl.
        apply (DisjList_spec_1 idx_dec); intros.
        apply in_map_iff in H8; destruct H8 as [idm [? ?]].
        rewrite Forall_forall in H2; specialize (H2 _ H9); dest; subst.
        intro; dest_in; auto.
  Qed.

  Ltac solve_msg :=
    simpl;
    try match goal with
        | [H: msg_id ?rmsg = _ |- msg_id ?rmsg <> _] => rewrite H
        end;
    discriminate.

  Ltac solve_enqMsgs :=
    let idm := fresh "idm" in
    let Hin := fresh "H" in
    apply Forall_forall; intros idm Hin;
    apply in_map_iff in Hin; dest; subst;
    solve_msg.

  Ltac solve_deqMsgs_NoDup :=
    match goal with
    | [H: ValidMsgsIn _ ?msgs |- NoDup (idsOf ?msgs)] => apply H
    end.

  Ltac solve_deqMsgs_msg_id :=
    match goal with
    | [H: Forall (fun _ => msg_id _ = _) ?msgs |- Forall _ ?msgs] =>
      eapply Forall_impl; [|eapply H];
      simpl; intros; split; solve_msg
    end.

  Ltac simpl_InvDirE_msgs :=
    try match goal with
        | [Hr: idsOf _ = map fst ?rss |- context [map fst ?rss] ] => rewrite <-Hr
        end;
    repeat
      (first [apply InvDirE_enqMP; [|solve_msg..]
             |apply InvDirE_enqMsgs; [|solve_enqMsgs]
             |eapply InvDirE_deqMP; [|eassumption|solve_msg..]
             |apply InvDirE_deqMsgs; [|eassumption
                                      |solve_deqMsgs_NoDup
                                      |solve_deqMsgs_msg_id]
             |assumption]).

  Ltac disc_ObjDirE :=
    match goal with
    | [H: ObjDirE _ _ _ |- _] =>
      red in H; simpl in H; dest; subst
    end.

  Ltac disc_NoRsME :=
    repeat
      match goal with
      | [H: ValidMsgsIn _ _ |- _] => destruct H
      | [H: ValidMsgsOut _ _ |- _] => destruct H
      end;
    repeat
      match goal with
      | [H: NoRsME _ _ |- _] => disc_MsgsP H
      | [Hi: NoRsME _ ?msgs -> _ /\ _,  Hm: MsgsP _ ?msgs |- _] =>
        specialize (Hi Hm); dest
      end.

  Ltac disc :=
    repeat
      match goal with
      | [Hi: InvDirE _ _ |- InvDirE _ _] =>
        let Hp := fresh "H" in
        red; simpl; intros ? ? Hp;
        specialize (Hi _ _ Hp); simpl in Hi;
        mred; simpl;
        try (exfalso; eapply parentIdxOf_not_eq; subst topo; eauto; fail)
      | |- _ <+- _; _ => disc_bind_true
      | |- _ -> _ => intros
      | [Hi: ObjDirE _ _ _ -> _, Ho: ObjDirE _ _ _ |- _] =>
        specialize (Hi Ho); dest
      | [Hi: NoRsME _ _ -> _, Hm: NoRsME _ _ |- _] =>
        specialize (Hi Hm)
      | [Hi: ObjCohDirE ?ost -> _, Hm: ObjCohDirE ?ost |- _] =>
        specialize (Hi Hm)
      | [H: ?t = ?t -> _ |- _] => specialize (H eq_refl); dest
      end.

  Ltac solve_by_diff_dir :=
    intros;
    match goal with
    | [Hn: ObjDirE _ _ _ |- _] =>
      red in Hn; dest; simpl in *; solve_mesi
    end.

  Ltac solve_by_idx_false :=
    intros; subst topo; congruence.

  Ltac solve_by_NoRsME_false :=
    exfalso;
    match goal with
    | [Hn: NoRsME _ (enqMP ?midx ?msg ?msgs) |- _] =>
      specialize (Hn (midx, msg)
                     (InMP_or_enqMP
                        msgs (or_introl (conj eq_refl eq_refl))));
      red in Hn; unfold map in Hn;
      disc_caseDec Hn; auto
    end.

  Ltac solve_ObjCohDirE :=
    try assumption;
    match goal with
    | [H: ObjCohDirE _ |- _] =>
      red in H; dest; red; simpl in *
    end;
    try match goal with
        | [H: context [invalidate ?st] |- _] =>
          pose proof (invalidate_sound st)
        | |- context [invalidate ?st] =>
          pose proof (invalidate_sound st)
        end;
    intuition solve_mesi.

  Ltac solve_coh :=
    intros;
    match goal with
    | [H: _ -> _ -> fst ?lv = fst ?rv |- fst ?lv = fst ?rv] =>
      apply H; [disc_NoRsME; assumption|solve_ObjCohDirE]
    end.

  Ltac solve_by_ObjCohDirE_false :=
    intros;
    try match goal with
        | [H: context [invalidate ?st] |- _] =>
          pose proof (invalidate_sound st)
        | |- context [invalidate ?st] =>
          pose proof (invalidate_sound st)
        end;
    match goal with
    | [H: ObjCohDirE _ |- _] =>
      red in H; simpl in *; dest; solve [congruence|solve_mesi]
    end.

  Ltac solve_valid :=
    split; [solve_MsgsP|solve_coh].

  Ltac solve_by_child_downlock_to_parent oidx :=
    exfalso;
    disc_MsgConflictsInv oidx;
    match goal with
    | [Hp: ParentLockFreeConflicts oidx ?porq ?orq,
           Ho: ?orq@[downRq] = None,
               Hpo: ?porq@[downRq] = Some _ |- _] =>
      specialize (Hp Ho); rewrite Hpo in Hp;
      simpl in Hp; auto
    end.

  Ltac solve_by_NoRsSI_false :=
    exfalso;
    match goal with
    | [Hn: NoRsSI _ ?msgs, Hf: FirstMPI ?msgs (?midx, ?msg) |- _] =>
      specialize (Hn (midx, msg) (FirstMP_InMP Hf));
      solve_MsgsP_false Hn;
      auto
    end.

  Lemma mesi_InvDirE_step:
    Invariant.InvStep impl step_m (InvDirE topo).
  Proof. (* SKIP_PROOF_ON
    red; intros.
    pose proof (tree2Topo_TreeTopoNode tr 0) as Htn.
    pose proof (footprints_ok
                  (mesi_GoodORqsInit Htr)
                  (mesi_GoodRqRsSys Htr) H) as Hftinv.
    pose proof (mesi_InObjInds H) as Hioi.
    pose proof (mesi_MsgConflictsInv
                  (@mesi_RootChnInv_ok _ Htr) H) as Hpmcf.
    pose proof (mesi_InvWBDir_ok H) as Hwd.
    pose proof (MesiDownLockInv_ok H) as Hmdl.
    pose proof (mesi_InvL1DirI_ok H) as Hl1d.
    pose proof (mesi_InvDirME_ok H) as Hdme.
    inv H1; [assumption
            |apply mesi_InvDirE_ext_in; auto
            |apply mesi_InvDirE_ext_out; auto
            |].

    simpl in H2; destruct H2; [subst|apply in_app_or in H1; destruct H1].

    - (*! Cases for the main memory *)

      (** Abstract the root. *)
      assert (In (rootOf (fst (tree2Topo tr 0)))
                 (c_li_indices (snd (tree2Topo tr 0)))) as Hin.
      { rewrite c_li_indices_head_rootOf by assumption.
        left; reflexivity.
      }

      remember (rootOf (fst (tree2Topo tr 0))) as oidx; clear Heqoidx.

      (** Do case analysis per a rule. *)
      apply concat_In in H3; destruct H3 as [crls [? ?]].
      apply in_map_iff in H1; destruct H1 as [cidx [? ?]]; subst.

      (** Derive that the child has the parent. *)
      assert (parentIdxOf (fst (tree2Topo tr 0)) cidx = Some oidx)
        by (apply subtreeChildrenIndsOf_parentIdxOf; auto).

      dest_in.

      { (* [liGetSImmME] *)
        disc_rule_conds_ex; disc.
        { solve_valid. }
        { disc_ObjDirE.
          split; intros.
          { apply MsgsP_enqMP.
            { derive_child_idx_in oidx0.
              disc_MsgConflictsInv oidx0.
              apply MsgsNotExist_MsgsP; simpl.
              apply MsgsP_deqMP.
              solve_MsgsNotExist_base.
              solve_RsDown_by_rqUp oidx0.
            }
            { red; unfold map.
              rewrite caseDec_head_eq by reflexivity.
              reflexivity.
            }
          }
          { solve_by_NoRsME_false. }
        }
        { destruct (idx_dec cidx oidx0); subst.
          { solve_by_idx_false. }
          { solve_valid. }
        }
      }

      { (* [liGetMImm] *)
        disc_rule_conds_ex; disc.
        { solve_valid. }
        { solve_by_diff_dir. }
        { destruct (idx_dec cidx oidx0); subst.
          { solve_by_idx_false. }
          { solve_valid. }
        }
      }

      { (* [liInvImmE] *)
        disc_rule_conds_ex; simpl_InvDirE_msgs; disc.
        { split; [solve_MsgsP|disc_getDir; solve_coh]. }
        { solve_by_diff_dir. }
      }

      { (* [liInvImmWBME] *)
        disc_rule_conds_ex; simpl_InvDirE_msgs; disc.
        { split; [solve_MsgsP|solve_by_ObjCohDirE_false]. }
        { solve_by_diff_dir. }
      }

    - (*! Cases for Li caches *)

      (** Derive some necessary information: each Li has a parent. *)
      apply in_map_iff in H1; destruct H1 as [oidx [? ?]]; subst; simpl in *.

      pose proof (c_li_indices_tail_has_parent Htr _ _ H2).
      destruct H1 as [pidx [? ?]].
      pose proof (Htn _ _ H4); dest.

      (** Do case analysis per a rule. *)
      apply in_app_or in H3; destruct H3.

      1: { (** Rules per a child *)
        apply concat_In in H3; destruct H3 as [crls [? ?]].
        apply in_map_iff in H3; destruct H3 as [cidx [? ?]]; subst.

        (** Derive that the child has the parent. *)
        assert (parentIdxOf (fst (tree2Topo tr 0)) cidx = Some oidx)
          by (apply subtreeChildrenIndsOf_parentIdxOf; auto).

        dest_in.

        { (* [liGetSImmS] *)
          disc_rule_conds_ex; disc.
          { solve_valid. }
          { solve_by_diff_dir. }
          { destruct (idx_dec cidx oidx0); subst.
            { solve_by_idx_false. }
            { solve_valid. }
          }
        }

        { (* [liGetSImmME] *)
          disc_rule_conds_ex; disc.
          { solve_valid. }
          { disc_ObjDirE.
            split; intros.
            { apply MsgsP_enqMP.
              { derive_child_idx_in oidx0.
                disc_MsgConflictsInv oidx0.
                apply MsgsNotExist_MsgsP; simpl.
                apply MsgsP_deqMP.
                solve_MsgsNotExist_base.
                solve_RsDown_by_rqUp oidx0.
              }
              { red; unfold map.
                rewrite caseDec_head_eq by reflexivity.
                reflexivity.
              }
            }
            { solve_by_NoRsME_false. }
          }
          { destruct (idx_dec cidx oidx0); subst.
            { solve_by_idx_false. }
            { solve_valid. }
          }
        }

        { (* [liGetSRqUpUp] *)
          disc_rule_conds_ex; simpl_InvDirE_msgs.
          disc; red in H18; mred.
          specialize (H0 H18); dest.
          solve_valid.
        }

        { (* [liGetSRqUpDownME] *)
          disc_rule_conds_ex; simpl_InvDirE_msgs; disc.
          disc_ObjDirE; mred.
        }

        { (* [liGetMImm] *)
          disc_rule_conds_ex; disc.
          { solve_valid. }
          { solve_by_diff_dir. }
          { destruct (idx_dec cidx oidx0); subst.
            { solve_by_idx_false. }
            { solve_valid. }
          }
        }

        { (* [liGetMRqUpUp] *)
          disc_rule_conds_ex; simpl_InvDirE_msgs.
          disc; red in H18; mred.
          specialize (H0 H18); dest.
          solve_valid.
        }

        { (* [liGetMRqUpDownME] *)
          disc_rule_conds_ex; simpl_InvDirE_msgs; disc.
          disc_ObjDirE; mred.
        }
        { (* [liGetMRqUpDownS] *)
          disc_rule_conds_ex; simpl_InvDirE_msgs; disc.
          disc_ObjDirE; mred.
        }

        { (* [liInvImmI] *)
          disc_rule_conds_ex; simpl_InvDirE_msgs; disc.
        }

        { (* [liInvImmS00] *)
          disc_rule_conds_ex; simpl_InvDirE_msgs; disc.
          { solve_valid. }
          { solve_by_diff_dir. }
        }

        { (* [liInvImmS01] *)
          disc_rule_conds_ex; simpl_InvDirE_msgs; disc.
          { split; [solve_MsgsP|solve_by_ObjCohDirE_false]. }
          { solve_by_diff_dir. }
        }

        { (* [liInvImmS1] *)
          disc_rule_conds_ex; simpl_InvDirE_msgs; disc.
          { solve_valid. }
          { solve_by_diff_dir. }
        }

        { (* [liInvImmE] *)
          disc_rule_conds_ex; simpl_InvDirE_msgs; disc.
          { split; [solve_MsgsP|disc_getDir; solve_coh]. }
          { solve_by_diff_dir. }
        }

        { (* [liInvImmWBI] *)
          disc_rule_conds_ex; simpl_InvDirE_msgs; disc.
        }

        { (* [liInvImmWBS0] *)
          disc_rule_conds_ex; simpl_InvDirE_msgs; disc.
          { solve_valid. }
          { solve_by_diff_dir. }
        }

        { (* [liInvImmWBS1] *)
          disc_rule_conds_ex; simpl_InvDirE_msgs; disc.
          { solve_valid. }
          { solve_by_diff_dir. }
        }

        { (* [liInvImmWBS] *)
          disc_rule_conds_ex; simpl_InvDirE_msgs; disc.
          { split; [solve_MsgsP|solve_by_ObjCohDirE_false]. }
          { solve_by_diff_dir. }
        }

        { (* [liInvImmWBME] *)
          disc_rule_conds_ex; simpl_InvDirE_msgs; disc.
          { split; [solve_MsgsP|solve_by_ObjCohDirE_false]. }
          { solve_by_diff_dir. }
        }
      }

      dest_in.

      { (* [liGetSRsDownDownS] *)
        disc_rule_conds_ex.
        derive_footprint_info_basis oidx.
        derive_child_chns cidx.
        disc_rule_conds_ex.
        disc.
        { split; [solve_MsgsP|].

          subst topo; disc_rule_conds_ex.
          intros.

          (** TODO: make an Ltac [disc_InvDirME] .. *)
          move Hdme at bottom.
          red in Hdme; simpl in Hdme.
          specialize (Hdme _ _ H4).
          disc_rule_conds_ex.
          disc_NoRsME.
          specialize (Hdme (ObjDirE_ObjDirME H29)).
          specialize (Hdme H31); dest.

          solve_by_NoRsSI_false.
        }
        { solve_by_diff_dir. }
        { destruct (idx_dec cidx oidx0); subst.
          { solve_by_idx_false. }
          { solve_valid. }
        }
      }

      { (* [liGetSRsDownDownE] *)
        disc_rule_conds_ex.
        derive_footprint_info_basis oidx.
        derive_child_chns cidx.
        disc_rule_conds_ex.
        disc.
        { split; [solve_MsgsP|].
          (* pulling a coherence value from the [mesiRsE] message. *)
          intros.
          move H0 at bottom.
          specialize (H0 _ (FirstMP_InMP H21)).
          red in H0.
          unfold map in H0.
          rewrite caseDec_head_eq in H0 by (unfold sigOf; simpl; congruence).
          auto.
        }
        { disc_ObjDirE.
          split; intros.
          { apply MsgsP_enqMP.
            { derive_child_idx_in oidx0.
              disc_MsgConflictsInv oidx0.
              apply MsgsNotExist_MsgsP; simpl.
              apply MsgsP_deqMP.
              solve_MsgsNotExist_base.
              solve_RsDown_by_parent_lock oidx0.
            }
            { red; unfold map.
              rewrite caseDec_head_eq by reflexivity.
              reflexivity.
            }
          }
          { solve_by_NoRsME_false. }
        }
        { destruct (idx_dec cidx oidx0); subst.
          { solve_by_idx_false. }
          { solve_valid. }
        }
      }

      { (* [liDownSRsUpDownME] *)
        disc_rule_conds_ex; simpl_InvDirE_msgs; disc.
        { split; [solve_MsgsP|solve_by_ObjCohDirE_false]. }
        { solve_by_diff_dir. }
      }

      { (* [liDownSImm] *)
        disc_rule_conds_ex; simpl_InvDirE_msgs; disc.
        exfalso.
        subst topo; disc_rule_conds_ex.
        disc_ObjDirE.
        remember (dir_excl _) as oidx; clear Heqoidx.
        derive_parent_downlock_by_RqDown oidx.
        auto.
      }

      { (* [liDownSRqDownDownME] *)
        disc_rule_conds_ex; simpl_InvDirE_msgs; disc.
        disc_ObjDirE; mred.
      }

      { (* [liDownSRsUpUp] *)
        disc_rule_conds_ex.
        disc_MesiDownLockInv oidx Hmdl.
        simpl_InvDirE_msgs; disc.
        { disc_ObjDirE.
          remember (dir_excl _) as oidx; clear Heqoidx.
          disc_MsgConflictsInv oidx.

          solve_by_child_downlock_to_parent oidx.
        }
        { solve_by_diff_dir. }
      }

      { (* [liGetMRsDownDownDirI] *)
        disc_rule_conds_ex.
        derive_footprint_info_basis oidx.
        derive_child_chns cidx.
        disc_rule_conds_ex.
        disc.
        { split; [solve_MsgsP|solve_by_ObjCohDirE_false]. }
        { solve_by_diff_dir. }
        { destruct (idx_dec cidx oidx0); subst.
          { solve_by_idx_false. }
          { solve_valid. }
        }
      }

      { (* [liGetMRsDownRqDownDirS] *)
        disc_rule_conds_ex.
        derive_footprint_info_basis oidx.
        simpl_InvDirE_msgs; disc.
        { split; [solve_MsgsP|solve_by_ObjCohDirE_false]. }
        { solve_by_diff_dir. }
        { solve_valid. }
      }

      { (* [liDownIRsUpDownS] *)
        disc_rule_conds_ex.
        disc_MesiDownLockInv oidx Hmdl.
        simpl_InvDirE_msgs; disc.
        { solve_valid. }
        { solve_by_diff_dir. }
      }

      { (* [liDownIRsUpDownME] *)
        disc_rule_conds_ex.
        disc_MesiDownLockInv oidx Hmdl.
        simpl_InvDirE_msgs; disc.
        { solve_valid. }
        { solve_by_diff_dir. }
      }

      { (* [liDownIImmS] *)
        disc_rule_conds_ex; simpl_InvDirE_msgs; disc.
        exfalso.
        subst topo; disc_rule_conds_ex.
        disc_ObjDirE.
        remember (dir_excl _) as oidx; clear Heqoidx.
        derive_parent_downlock_by_RqDown oidx.
        auto.
      }

      { (* [liDownIImmME] *)
        disc_rule_conds_ex; simpl_InvDirE_msgs; disc.
        exfalso.
        subst topo; disc_rule_conds_ex.
        disc_ObjDirE.
        remember (dir_excl _) as oidx; clear Heqoidx.
        derive_parent_downlock_by_RqDown oidx.
        auto.
      }

      { (* [liDownIRqDownDownDirS] *)
        disc_rule_conds_ex; simpl_InvDirE_msgs; disc.
        disc_ObjDirE; mred.
      }
      { (* [liDownIRqDownDownDirME] *)
        disc_rule_conds_ex; simpl_InvDirE_msgs; disc.
        disc_ObjDirE; mred.
      }
      { (* [liDownIRqDownDownDirMES] *)
        disc_rule_conds_ex; simpl_InvDirE_msgs; disc.
        disc_ObjDirE; mred.
      }

      { (* [liDownIRsUpUpS] *)
        disc_rule_conds_ex.
        disc_MesiDownLockInv oidx Hmdl.
        simpl_InvDirE_msgs; disc.
        { subst topo; disc_rule_conds_ex.
          disc_ObjDirE.
          remember (dir_excl _) as oidx; clear Heqoidx.
          disc_MsgConflictsInv oidx.
          solve_by_child_downlock_to_parent oidx.
        }
        { solve_by_diff_dir. }
      }

      { (* [liDownIRsUpUpME] *)
        disc_rule_conds_ex.
        disc_MesiDownLockInv oidx Hmdl.
        simpl_InvDirE_msgs; disc.
        { subst topo; disc_rule_conds_ex.
          disc_ObjDirE.
          remember (dir_excl _) as oidx; clear Heqoidx.
          disc_MsgConflictsInv oidx.
          solve_by_child_downlock_to_parent oidx.
        }
        { solve_by_diff_dir. }
      }

      { (* [liDownIRsUpUpMES] *)
        disc_rule_conds_ex.
        disc_MesiDownLockInv oidx Hmdl.
        simpl_InvDirE_msgs; disc.
        { subst topo; disc_rule_conds_ex.
          disc_ObjDirE.
          remember (dir_excl _) as oidx; clear Heqoidx.
          disc_MsgConflictsInv oidx.
          solve_by_child_downlock_to_parent oidx.
        }
        { solve_by_diff_dir. }
      }

      { (* [liInvRqUpUp] *)
        disc_rule_conds_ex; simpl_InvDirE_msgs; disc.
        disc_ObjDirE; solve_mesi.
      }

      { (* [liInvRqUpUpWB] *)
        disc_rule_conds_ex; simpl_InvDirE_msgs; disc.
        disc_ObjDirE; solve_mesi.
      }

      { (* [liInvRsDownDown] *)
        disc_rule_conds_ex.
        derive_footprint_info_basis oidx.
        derive_InvWBDir oidx.
        assert (ObjInvRs oidx msgs) as Hirs.
        { do 2 red.
          eexists; split; [apply FirstMP_InMP; eassumption|].
          unfold sigOf; simpl; congruence.
        }
        specialize (Hwd (or_intror (or_intror Hirs))); clear Hirs.

        simpl_InvDirE_msgs; disc.
        { split; [solve_MsgsP|solve_by_ObjCohDirE_false]. }
        { disc_ObjDirE; solve_mesi. }
      }

      { (* [liDropImm] *)
        disc_rule_conds_ex; disc; solve_valid.
      }

    - (*! Cases for L1 caches *)

      (** Derive some necessary information: each Li has a parent. *)
      apply in_map_iff in H1; destruct H1 as [oidx [? ?]]; subst.

      pose proof (c_l1_indices_has_parent Htr _ _ H2).
      destruct H1 as [pidx [? ?]].
      pose proof (Htn _ _ H4); dest.

      (** Discharge an invariant that holds only for L1 caches. *)
      red in Hl1d; simpl in Hl1d.
      rewrite Forall_forall in Hl1d; specialize (Hl1d _ H2).
      simpl in H5; rewrite H5 in Hl1d; simpl in Hl1d.

      (** Do case analysis per a rule. *)
      dest_in.

      { disc_rule_conds_ex; simpl_InvDirE_msgs; disc. }

      { disc_rule_conds_ex; simpl_InvDirE_msgs; disc.
        red in H16; mred; specialize (H0 H16); dest.
        solve_valid.
      }

      { disc_rule_conds_ex; simpl_InvDirE_msgs.
        derive_footprint_info_basis oidx.
        derive_child_chns cidx.
        disc_rule_conds_ex.
        disc.
        { split; [solve_MsgsP|].

          subst topo; disc_rule_conds_ex.
          intros.

          (** TODO: make an Ltac [disc_InvDirME] .. *)
          move Hdme at bottom.
          red in Hdme; simpl in Hdme.
          specialize (Hdme _ _ H4).
          disc_rule_conds_ex.
          specialize (Hdme (ObjDirE_ObjDirME H28)).
          specialize (Hdme H30); dest.

          solve_by_NoRsSI_false.
        }
        { solve_by_diff_dir. }
      }

      { disc_rule_conds_ex.
        derive_footprint_info_basis oidx.
        derive_child_chns cidx.
        disc_rule_conds_ex.
        disc.
        { split; [solve_MsgsP|].
          (* pulling a coherence value from the [mesiRsE] message. *)
          intros.
          move H0 at bottom.
          specialize (H0 _ (FirstMP_InMP H21)).
          red in H0.
          unfold map in H0.
          rewrite caseDec_head_eq in H0 by (unfold sigOf; simpl; congruence).
          auto.
        }
        { disc_ObjDirE; solve_mesi. }
        { destruct (idx_dec (l1ExtOf oidx) oidx0); subst.
          { exfalso.
            subst topo.
            rewrite tree2Topo_l1_ext_parent in H3 by assumption.
            congruence.
          }
          { solve_valid. }
        }
      }

      { disc_rule_conds_ex; simpl_InvDirE_msgs; disc.
        exfalso.
        subst topo; disc_rule_conds_ex.
        disc_ObjDirE.
        remember (dir_excl _) as oidx; clear Heqoidx.
        derive_parent_downlock_by_RqDown oidx.
        auto.
      }

      { disc_rule_conds_ex; simpl_InvDirE_msgs; disc.
        { split; [solve_MsgsP|solve_by_ObjCohDirE_false]. }
        { solve_by_diff_dir. }
      }

      { disc_rule_conds_ex; simpl_InvDirE_msgs; disc.
        { split; [solve_MsgsP|solve_by_ObjCohDirE_false]. }
        { solve_by_diff_dir. }
      }

      { disc_rule_conds_ex; simpl_InvDirE_msgs.
        disc; red in H16; mred.
        specialize (H0 H16); dest.
        solve_valid.
      }

      { disc_rule_conds_ex.
        derive_footprint_info_basis oidx.
        derive_child_chns cidx.
        disc_rule_conds_ex.
        disc.
        { split; [solve_MsgsP|solve_by_ObjCohDirE_false]. }
        { solve_by_diff_dir. }
        { destruct (idx_dec (l1ExtOf oidx) oidx0); subst.
          { exfalso.
            subst topo.
            rewrite tree2Topo_l1_ext_parent in H3 by assumption.
            congruence.
          }
          { solve_valid. }
        }
      }

      { disc_rule_conds_ex; simpl_InvDirE_msgs; disc.
        exfalso.
        subst topo; disc_rule_conds_ex.
        disc_ObjDirE.
        remember (dir_excl _) as oidx; clear Heqoidx.
        derive_parent_downlock_by_RqDown oidx.
        auto.
      }

      { disc_rule_conds_ex; simpl_InvDirE_msgs; disc.
        exfalso.
        subst topo; disc_rule_conds_ex.
        disc_ObjDirE.
        remember (dir_excl _) as oidx; clear Heqoidx.
        derive_parent_downlock_by_RqDown oidx.
        auto.
      }

      { disc_rule_conds_ex; simpl_InvDirE_msgs; disc.
        disc_ObjDirE; solve_mesi.
      }

      { disc_rule_conds_ex; simpl_InvDirE_msgs; disc.
        disc_ObjDirE; solve_mesi.
      }

      { disc_rule_conds_ex.
        derive_footprint_info_basis oidx.
        derive_InvWBDir oidx.
        assert (ObjInvRs oidx msgs) as Hirs.
        { do 2 red.
          eexists; split; [apply FirstMP_InMP; eassumption|].
          unfold sigOf; simpl; congruence.
        }
        specialize (Hwd (or_intror (or_intror Hirs))); clear Hirs.

        simpl_InvDirE_msgs; disc.
        { split; [solve_MsgsP|solve_by_ObjCohDirE_false]. }
        { disc_ObjDirE; solve_mesi. }
      }

      END_SKIP_PROOF_ON *) admit.
  Qed.

  Theorem mesi_InvDirE_ok:
    InvReachable impl step_m (InvDirE topo).
  Proof.
    eapply inv_reachable.
    - typeclasses eauto.
    - apply mesi_InvDirE_init.
    - apply mesi_InvDirE_step.
  Qed.

End InvDirE.

Definition InvNWB (topo: DTree) (st: State): Prop :=
  forall oidx pidx,
    parentIdxOf topo oidx = Some pidx ->
    ost <+- (st_oss st)@[oidx];
      orq <+- (st_orqs st)@[oidx];
      post <+- (st_oss st)@[pidx];
      porq <+- (st_orqs st)@[pidx];
      (ObjDirE porq post oidx ->
       ObjInvRq oidx (st_msgs st) ->
       NoRsI oidx (st_msgs st) /\ mesiS <= ost#[status] /\
       ost#[val] = post#[val]).

Section InvNWB.
  Variable (tr: tree).
  Hypothesis (Htr: tr <> Node nil).

  Let topo: DTree := fst (tree2Topo tr 0).
  Let cifc: CIfc := snd (tree2Topo tr 0).
  Let impl: System := impl Htr.

  Theorem mesi_InvNWB_ok:
    InvReachable impl step_m (InvNWB topo).
  Proof.
    red; intros.
    pose proof (mesi_InObjInds H) as Hoin.
    pose proof (mesi_MsgConflictsInv (@mesi_RootChnInv_ok _ Htr) H) as Hmcf.
    pose proof (mesi_InvDirME_ok H) as Hdme.
    pose proof (mesi_InvNotOwned_ok H) as Hno.
    pose proof (mesi_InvDirE_ok H) as Hde.
    pose proof (mesi_InvWBDir_ok H) as Hwd.

    red; intros.
    specialize (Hoin oidx).
    specialize (Hmcf oidx).
    specialize (Hdme _ _ H0).
    specialize (Hno oidx).
    specialize (Hde _ _ H0).
    specialize (Hwd oidx).

    destruct (st_oss ist)@[oidx] as [ost|] eqn:Host; simpl in *; auto.
    destruct (st_orqs ist)@[oidx] as [orq|] eqn:Horq; simpl in *; auto.
    destruct (st_oss ist)@[pidx] as [post|] eqn:Hpost; simpl in *; auto.
    destruct (st_orqs ist)@[pidx] as [porq|] eqn:Hporq; simpl in *; auto.

    specialize (Hmcf _ Hoin eq_refl); dest.
    intros.
    specialize (Hwd (or_intror (or_introl H7))).
    specialize (Hno H7).
    specialize (Hde H6).
    destruct Hde as [_ Hde].
    specialize (Hdme (ObjDirE_ObjDirME H6)).

    assert (NoRsME oidx (st_msgs ist)) as Hnrs.
    { destruct H7 as [[rqUp rqm] ?]; dest; inv H8.
      apply not_MsgExistsSig_MsgsNotExist.
      intros; dest_in.
      { destruct H9 as [[rsDown rsm] ?]; dest; inv H9.
        specialize (H2 (rqUpFrom oidx, rqm) eq_refl H7); dest.
        eapply H10 with (rsDown:= (downTo oidx, rsm)); eauto.
      }
      { destruct H9 as [[rsDown rsm] ?]; dest; inv H9.
        specialize (H2 (rqUpFrom oidx, rqm) eq_refl H7); dest.
        eapply H10 with (rsDown:= (downTo oidx, rsm)); eauto.
      }
    }

    specialize (Hdme Hnrs); destruct Hdme as [Hnrsi Hdme].

    assert (mesiS <= ost#[status]) as Hs.
    { specialize (Hdme ltac:(solve_mesi)).
      destruct Hdme; dest; simpl in *; solve_mesi.
    }

    assert (ObjCohDirE ost) as Hode.
    { split; [assumption|left; assumption]. }
    specialize (Hde Hnrs Hode).

    repeat split.
    - clear -Hnrsi.
      do 3 red; intros.
      specialize (Hnrsi _ H).
      red in Hnrsi.
      rewrite map_trans in Hnrsi; do 2 rewrite map_cons in Hnrsi.
      red in Hnrsi.
      do 2 (destruct (sig_dec _ _); [exfalso; auto|]).
      clear Hnrsi.
      red.
      rewrite map_trans, map_cons.
      rewrite caseDec_head_neq by assumption.
      simpl; auto.
    - assumption.
    - apply eq_sym; assumption.
  Qed.

End InvNWB.


(**************************************************************************)
(*  This file is part of CertrBPF,                                        *)
(*  a formally verified rBPF verifier + interpreter + JIT in Coq.         *)
(*                                                                        *)
(*  Copyright (C) 2022 Inria                                              *)
(*                                                                        *)
(*  This program is free software; you can redistribute it and/or modify  *)
(*  it under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation; either version 2 of the License, or     *)
(*  (at your option) any later version.                                   *)
(*                                                                        *)
(*  This program is distributed in the hope that it will be useful,       *)
(*  but WITHOUT ANY WARRANTY; without even the implied warranty of        *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         *)
(*  GNU General Public License for more details.                          *)
(*                                                                        *)
(**************************************************************************)

From Coq Require Import List Lia ZArith.
From compcert Require Import Integers Values Clight Memory.
Import ListNotations.

From bpf.comm Require Import Monad.
From bpf.clightlogic Require Import CommonLemma CommonLib Clightlogic CorrectRel.
From bpf.verifier.comm Require Import monad.

From bpf.verifier.synthesismodel Require Import verifier_synthesis.
From bpf.verifier.clightmodel Require Import verifier.
From bpf.verifier.simulation Require Import VerifierSimulation VerifierRel.

(**
Check is_well_dst.
is_well_dst
     : int64 -> M bool
*)

Section Is_well_dst.
  Context {S: special_blocks}.

  (** The program contains our function of interest [fn] *)
  Definition p : Clight.program := prog.

  (* [Args,Res] provides the mapping between the Coq and the C types *)
  (* Definition Args : list CompilableType := [stateCompilableType].*)
  Definition args : list Type := [(int64:Type)].
  Definition res : Type := (bool:Type).

  (* [f] is a Coq Monadic function with the right type *)
  Definition f : arrow_type args (M state.state res) := is_well_dst.

  (* [fn] is the Cligth function which has the same behaviour as [f] *)
  Definition fn: Clight.function := f_is_well_dst.

  (* [match_arg] relates the Coq arguments and the C arguments *)
  Definition match_arg_list : DList.t (fun x => x -> Inv _) args :=
    dcons (fun x => StateLess _ (int64_correct x))
        (DList.DNil _).

  (* [match_res] relates the Coq result and the C result *)
  Definition match_res : res -> Inv state.state := fun x  => StateLess _ (bool_correct x).

  Instance correct_function_is_well_dst : forall a, correct_function _ p args res f fn ModNothing true match_state match_arg_list match_res a.
  Proof.
    correct_function_from_body args.
    correct_body.

    unfold f. unfold is_well_dst.
    correct_forward.

    get_invariant _i.
    unfold eval_inv, int64_correct in c0.
    subst.

    eexists.

    split_and; auto.
    {
      unfold exec_expr. repeat
      match goal with
      | H: ?X = _ |- context [match ?X with _ => _ end] =>
        rewrite H
      end. simpl.
      unfold Cop.sem_shr, Cop.sem_shift; simpl.
      change Int64.iwordsize with (Int64.repr 64).
      change (Int64.ltu (Int64.repr 8) (Int64.repr 64)) with true; simpl.
      unfold Cop.sem_cmp; simpl.
      unfold Cop.sem_binarith; simpl.
      unfold Val.of_bool; simpl.
      unfold Vtrue, Vfalse.
      reflexivity.
    }

    unfold eval_inv, match_res, state.is_well_dst'.
    unfold bool_correct, Val.of_bool, BinrBPF.get_dst.
    unfold Int.cmpu.
    destruct negb; reflexivity.
    unfold Cop.sem_cast; simpl.
    destruct negb; reflexivity.
    intros.
    destruct negb; constructor; reflexivity.
  Qed.

End Is_well_dst.

Existing  Instance correct_function_is_well_dst.


From RecordUpdate Require Import RecordSet.
From Perennial.Helpers Require Import Map.

From Perennial.program_logic Require Export weakestpre post_expr.
From Perennial.goose_lang Require Import crash_modality.
From Perennial.goose_lang Require Import proofmode wpc_proofmode notation crash_borrow.
From Perennial.base_logic Require Import lib.ghost_map.

From Goose.github_com.mit_pdos.perennial_examples Require Import alloc.
From Perennial.program_proof Require Import disk_prelude.
From Perennial.program_proof.examples Require Import alloc_addrset.

Section goose.
Context `{!heapGS Σ}.

Let allocN := nroot.@"allocator".

Implicit Types (a: u64) (m: gmap u64 ()) (free: gset u64).
Implicit Types (P: gset u64 → iProp Σ).
Implicit Types (l:loc).

Definition allocator_linv P (mref: loc) free : iProp Σ :=
  "Hfreemap" ∷ is_addrset mref (free) ∗
  "HP" ∷ P free
.

Definition is_allocator (l: loc) P : iProp Σ :=
  ∃ (lref mref: loc),
    "#Hsplit" ∷ □ (∀ σ1 σ2, ⌜ σ1 ## σ2 ⌝ → P (σ1 ∪ σ2) -∗ post_expr ∅ (P σ1 ∗ P σ2)) ∗
    "#Hjoin" ∷ □ (∀ σ1 σ2, P σ1 -∗ P σ2 -∗ post_expr ∅ (P (σ1 ∪ σ2))) ∗
    "#m" ∷ readonly (l ↦[Allocator :: "m"] #lref) ∗
    "#free" ∷ readonly (l ↦[Allocator :: "free"] #mref) ∗
    "#His_lock" ∷ is_lock allocN #lref (∃ σ, "Hlockinv" ∷ allocator_linv P mref σ)
.

Global Instance is_allocator_Persistent l P :
  Persistent (is_allocator l P).
Proof. apply _. Qed.

Theorem wp_newAllocator mref (start sz: u64) used P E :
  int.Z start + int.Z sz < 2^64 →
  {{{
       □ (∀ σ1 σ2, ⌜ σ1 ## σ2 ⌝ → P (σ1 ∪ σ2) -∗ post_expr ∅ (P σ1 ∗ P σ2)) ∗
       □ (∀ σ1 σ2, P σ1 -∗ P σ2 -∗ post_expr ∅ (P (σ1 ∪ σ2))) ∗
       is_addrset mref used ∗
      let σ0 := (rangeSet (int.Z start) (int.Z sz)) ∖ used in
       ▷ P σ0 }}}
    New #start #sz #mref @ E
  {{{ l, RET #l; is_allocator l P }}}.
Proof.
  iIntros (Hoverflow Φ) "(#Hsplit&#Hjoin&Hused&HP) HΦ".
  wp_call.
  wp_apply wp_freeRange; first by auto.
  iIntros (mref') "Hfree".
  wp_pures.
  wp_apply (wp_mapRemove with "[$Hfree $Hused]"); iIntros "(Hfree & Hused)".
  wp_apply wp_new_free_lock.
  iIntros (lk) "Hlock".
  rewrite -wp_fupd.
  wp_apply wp_allocStruct; auto.
  iIntros (l) "Hallocator".
  iDestruct (struct_fields_split with "Hallocator") as "(m&free&_)".
  iMod (readonly_alloc_1 with "m") as "#m".
  iMod (readonly_alloc_1 with "free") as "#free".
  iMod (alloc_lock allocN E _
                   (∃ σ, "Hlockinv" ∷ allocator_linv P mref' σ)%I
          with "[$Hlock] [-HΦ]") as "#Hlock".
  { iExists _; iFrame. }
  iModIntro.
  iApply ("HΦ" $! _).
  iExists _, _; iFrame "#".
Qed.

Lemma map_empty_difference `{Countable K} {V} (m: gmap K V) :
  ∅ ∖ m = ∅.
Proof.
  apply map_eq; intros.
  rewrite lookup_difference_None; eauto.
Qed.

Lemma set_empty_difference `{Countable K} (m: gset K) :
  ∅ ∖ m = ∅.
Proof.
  clear.
  set_solver.
Qed.

Theorem wp_Reserve l P :
  {{{ is_allocator l P }}}
    Allocator__Reserve #l
  {{{ a (ok: bool), RET (#a, #ok);
      if ok then P {[a]} else True%I }}}.
Proof.
  clear.
  iIntros (Φ) "Hinv HΦ"; iNamed "Hinv".
  wp_call.
  wp_loadField.
  wp_apply (acquire_spec with "His_lock").
  iIntros "(His_locked & Hinner)"; iNamed "Hinner".
  iNamed "Hlockinv".
  wp_loadField.
  wp_apply (wp_findKey with "Hfreemap").
  iIntros (k ok) "[%Hk Hfreemap]".
  wp_pures.
  wp_loadField.
  iDestruct "Hfreemap" as (m') "[Hfreemap %Hdom]".
  wp_apply (wp_MapDelete with "Hfreemap"); iIntros "Hfreemap".
  wp_pures.
  wp_bind (struct.loadF _ _ _).
  destruct ok.
  - assert (σ = (σ ∖ {[k]}) ∪ {[k]}) as ->.
    { rewrite difference_union_L. set_solver. }
    iDestruct ("Hsplit" with "[] HP") as "Hpost".
    { iPureIntro. set_solver. }
    iApply (wpc_wp NotStuck _ _ _ True).
    iApply (post_expr_elim with "Hpost"); first set_solver+; auto.
    iApply wp_wpc.
    wp_loadField.
    iIntros "(HP&Hk)".
    wp_apply (release_spec with "[-HΦ Hk $His_lock $His_locked]").
    { iNext. iExists _; iFrame.
      iExists _. iFrame. rewrite /map_del dom_delete_L. iPureIntro; congruence. }
    wp_pures.
    iApply "HΦ"; by iFrame.
  - wp_loadField.
    wp_apply (release_spec with "[-HΦ $His_lock $His_locked]").
    { iNext. iExists _; iFrame.
      iExists _. iFrame. rewrite /map_del dom_delete_L. subst.
      iPureIntro. rewrite Hdom. set_solver. }
    wp_pures.
    iApply "HΦ"; by iFrame.
Qed.

Lemma gset_difference_difference `{Countable K} (A B C: gset K) :
  C ⊆ A →
  A ∖ (B ∖ C) = A ∖ B ∪ C.
Proof using.
  clear.
  intros.
  apply set_eq; intros k.
  rewrite !elem_of_difference.
  intuition.
  - destruct (decide (k ∈ C)); set_solver.
  - set_solver.
  - set_solver.
Qed.

Theorem wp_Free P l (a: u64) :
  {{{ is_allocator l P ∗ P {[a]} }}}
    Allocator__Free #l #a
  {{{ RET #(); True }}}.
Proof.
  iIntros (Φ) "(Halloc&Ha) HΦ"; iNamed "Halloc".
  wp_call.
  wp_loadField.
  wp_apply (acquire_spec with "His_lock").
  iIntros "(Hlocked&Hinv)"; iNamed "Hinv".
  iNamed "Hlockinv".
  wp_loadField.
  iDestruct "Hfreemap" as (m) "[Hfreemap %Hdom]".
  wp_apply (wp_MapInsert _ _ _ _ () with "Hfreemap"); first by auto.
  iIntros "Hfreemap".
  iAssert (is_addrset mref (σ ∪ {[a]})) with "[Hfreemap]" as "Hfreemap".
  { iExists _; iFrame.
    iPureIntro.
    rewrite /map_insert dom_insert_L.
    set_solver. }
  wp_pures.
  wp_bind (struct.loadF _ _ _).
  iDestruct ("Hjoin" with "HP [$]") as "Hpost".
  iApply (wpc_wp NotStuck _ _ _ True).
  iApply (post_expr_elim with "Hpost"); first set_solver+; auto.
  iApply wp_wpc.
  wp_loadField.
  iIntros "HP".
  wp_apply (release_spec with "[$His_lock $Hlocked Hfreemap HP]").
  { iExists _; iFrame "HP". eauto. }
  wp_pures.
  iApply ("HΦ" with "[$]").
Qed.

End goose.

Opaque crash_borrow.

Section crash.
Context `{!heapGS Σ}.
Context `{!stagedG Σ}.

Implicit Types (a: u64) (m: gmap u64 ()) (free: gset u64).
Implicit Types (P: gset u64 → iProp Σ).
Implicit Types (l:loc).

Definition valid_allocPred (P Pc: gset u64 → iProp Σ) : iProp Σ :=
  (* Splitting/joining of P *)
  □ (∀ σ1 σ2, ⌜ σ1 ## σ2 ⌝ → P (σ1 ∪ σ2) -∗ (P σ1 ∗ P σ2)) ∗
  □ (∀ σ1 σ2, P σ1 -∗ P σ2 -∗ ⌜ σ1 ## σ2 ⌝ ∧ (P (σ1 ∪ σ2))) ∗
  (* Splitting/joining of Pc *)
  □ (∀ σ1 σ2, ⌜ σ1 ## σ2 ⌝ → Pc (σ1 ∪ σ2) -∗ (Pc σ1 ∗ Pc σ2)) ∗
  □ (∀ σ1 σ2, Pc σ1 -∗ Pc σ2 -∗ (Pc (σ1 ∪ σ2))) ∗
  (* P must imply Pc *)
  □ (∀ σ, P σ -∗ Pc σ).

Definition is_crash_allocator l P Pc :=
  is_allocator l (λ σ, crash_borrow (P σ) (Pc σ)).

Theorem wpc_newAllocator Φ Φc (mref : loc) (start sz: u64) used P Pc K `{!LanguageCtx K} :
  int.Z start + int.Z sz < 2^64 →
  let σ := (rangeSet (int.Z start) (int.Z sz)) ∖ used in
  valid_allocPred P Pc -∗
  P σ -∗
  is_addrset mref used -∗
  Φc ∧ (∀ l, is_crash_allocator l P Pc -∗
     WPC (K (of_val #l)) @ ⊤ {{ Φ }} {{ Φc }}) -∗
  WPC (K (New #start #sz #mref)) @ ⊤ {{ Φ }} {{ Φc ∗ Pc σ }}.
Proof.
  iIntros (Hbound) "#Hvalid HP Haddr HK".
  iApply (wpc_crash_borrow_init_ctx' _ _ _ _ (P _) (Pc _) with "[HP]"); auto.
  { iDestruct "Hvalid" as "(?&?&?&?&Himp)". by iApply "Himp". }
  iSplit.
  { iLeft in "HK". eauto. }
  iIntros "Hcb".
  iCache with "HK".
  { by iLeft in "HK". }
  wpc_frame.
  wp_apply (wp_newAllocator _ _ _ used (λ σ, crash_borrow (P σ) (Pc σ)) with "[$Hcb $Haddr]").
  { auto. }
  { iDestruct "Hvalid" as "(Hsplit1&Hjoin1&Hsplit2&Hjoin2&Himp)". iSplit.
    - iModIntro. iIntros (?? Hdisj) "H".
      iApply (crash_borrow_split_post with "H").
      { iApply "Hsplit1". eauto. }
      { iApply "Himp". }
      { iApply "Himp". }
      { iNext. iIntros "(H1&?)". iApply ("Hjoin2" with "H1 [$]"). }
    - iModIntro. iIntros (??) "H1 H2".
      iApply (crash_borrow_combine_post' with "H1 H2").
      {
        iNext. iIntros "(HP1&HP2)". iDestruct ("Hjoin1" with "HP1 [$]") as "(%Hdisj&HP)".
        iModIntro. iFrame.
        iSplit.
        * iIntros. iApply "Hsplit2"; auto.
        * iApply "Himp".
      }
  }
  iIntros (l) "Halloc HK".
  iApply "HK".
  iFrame.
Qed.

Theorem wp_crash_Reserve l P Pc :
  {{{ is_crash_allocator l P Pc }}}
    Allocator__Reserve #l
  {{{ a (ok: bool), RET (#a, #ok);
      if ok then crash_borrow (P {[a]}) (Pc {[a]}) else True%I }}}.
Proof.
  iIntros (Φ) "#Hc HΦ". wp_apply (wp_Reserve).
  { eauto. }
  iIntros (a ok) "H". iApply "HΦ".
  eauto.
Qed.

Theorem wp_crash_Free P Pc l (a: u64) :
  {{{ is_crash_allocator l P Pc ∗ crash_borrow (P {[a]}) (Pc {[a]}) }}}
    Allocator__Free #l #a
  {{{ RET #(); True }}}.
Proof.
  iIntros (Φ) "(#Hc&Hborrow) HΦ". wp_apply (wp_Free with "[Hborrow]").
  { iFrame "Hc". eauto. }
  by iApply "HΦ".
Qed.

End crash.