From iris.algebra Require Import auth excl gmap.
From iris.base_logic.lib Require Import own invariants gen_heap.
From iris.proofmode Require Import proofmode.
From iris.prelude Require Import options.

(** An "invariant" location is a location that has some invariant about its
value attached to it, and that can never be deallocated explicitly by the
program.  It provides a persistent witness that will always allow reading the
location, guaranteeing that the value read will satisfy the invariant.

This is useful for data structures like RDCSS that need to read locations long
after their ownership has been passed back to the client, but do not care *what*
it is that they are reading in that case. In that extreme case, the invariant
may just be [True].

Since invariant locations cannot be deallocated, they only make sense when
modeling languages with garbage collection.  HeapLang can be used to model
either language by choosing whether or not to use the [Free] operation.  By
using a separate assertion [inv_mapsto_own] for "invariant" locations, we can
keep all the other proofs that do not need it conservative.  *)

Definition inv_heapN: namespace := nroot .@ "inv_heap".
Local Notation "l ↦ v" := (mapsto l (DfracOwn 1) v) (at level 20) : bi_scope.

Definition inv_heap_mapUR (L V : Type) `{Countable L} : ucmra := gmapUR L $ prodR
  (optionR $ exclR $ leibnizO V)
  (agreeR (V -d> PropO)).

Definition to_inv_heap {L V : Type} `{Countable L}
    (h: gmap L (V * (V -d> PropO))) : inv_heap_mapUR L V :=
  prod_map (λ x, Excl' x) to_agree <$> h.

Class inv_heapGpreS (L V : Type) (Σ : gFunctors) `{Countable L} := {
  inv_heapGpreS_inG : inG Σ (authR (inv_heap_mapUR L V))
}.
Local Existing Instance inv_heapGpreS_inG.

Class inv_heapGS (L V : Type) (Σ : gFunctors) `{Countable L} := Inv_HeapG {
  inv_heap_inG : inv_heapGpreS L V Σ;
  inv_heap_name : gname
}.
Local Existing Instance inv_heap_inG.
Global Arguments Inv_HeapG _ _ {_ _ _ _}.
Global Arguments inv_heap_name {_ _ _ _ _} _ : assert.

Definition inv_heapΣ (L V : Type) `{Countable L} : gFunctors :=
  #[ GFunctor (authR (inv_heap_mapUR L V)) ].

Global Instance subG_inv_heapGpreS (L V : Type) `{Countable L} {Σ} :
  subG (inv_heapΣ L V) Σ → inv_heapGpreS L V Σ.
Proof. solve_inG. Qed.

Section definitions.
  Context {L V : Type} `{Countable L}.
  Context `{!invGS_gen hlc Σ, !gen_heapGS L V Σ, gG: !inv_heapGS L V Σ}.

  Definition inv_heap_inv_P : iProp Σ :=
    ∃ h : gmap L (V * (V -d> PropO)),
       own (inv_heap_name gG) (● to_inv_heap h) ∗
       [∗ map] l ↦ p ∈ h, ⌜p.2 p.1⌝ ∗ l ↦ p.1.

  Definition inv_heap_inv : iProp Σ := inv inv_heapN inv_heap_inv_P.

  Definition inv_mapsto_own (l : L) (v : V) (I : V → Prop) : iProp Σ :=
    own (inv_heap_name gG) (◯ {[l := (Excl' v, to_agree I) ]}).

  Definition inv_mapsto (l : L) (I : V → Prop) : iProp Σ :=
    own (inv_heap_name gG) (◯ {[l := (None, to_agree I)]}).

End definitions.

Local Notation "l '↦_' I v" := (inv_mapsto_own l v I%stdpp%type)
  (at level 20, I at level 9, format "l  '↦_' I  v") : bi_scope.

Local Notation "l '↦_' I □" := (inv_mapsto l I%stdpp%type)
  (at level 20, I at level 9, format "l  '↦_' I  '□'") : bi_scope.

(* [inv_heap_inv] has no parameters to infer the types from, so we need to
   make them explicit. *)
Global Arguments inv_heap_inv _ _ {_ _ _ _ _ _ _}.

Global Instance: Params (@inv_mapsto_own) 8 := {}.
Global Instance: Params (@inv_mapsto) 7 := {}.

Section to_inv_heap.
  Context {L V : Type} `{Countable L}.
  Implicit Types (h : gmap L (V * (V -d> PropO))).

  Lemma to_inv_heap_valid h : ✓ to_inv_heap h.
  Proof. intros l. rewrite lookup_fmap. by case (h !! l). Qed.

  Lemma to_inv_heap_singleton l v I :
    to_inv_heap {[l := (v, I)]} =@{inv_heap_mapUR L V} {[l := (Excl' v, to_agree I)]}.
  Proof. by rewrite /to_inv_heap fmap_insert fmap_empty. Qed.

  Lemma to_inv_heap_insert l v I h :
    to_inv_heap (<[l := (v, I)]> h) = <[l := (Excl' v, to_agree I)]> (to_inv_heap h).
  Proof. by rewrite /to_inv_heap fmap_insert. Qed.

  Lemma lookup_to_inv_heap_None h l :
    h !! l = None → to_inv_heap h !! l = None.
  Proof. by rewrite /to_inv_heap lookup_fmap=> ->. Qed.

  Lemma lookup_to_inv_heap_Some h l v I :
    h !! l = Some (v, I) → to_inv_heap h !! l = Some (Excl' v, to_agree I).
  Proof. by rewrite /to_inv_heap lookup_fmap=> ->. Qed.

  Lemma lookup_to_inv_heap_Some_2 h l v' I' :
    to_inv_heap h !! l ≡ Some (v', I') →
    ∃ v I, v' = Excl' v ∧ I' ≡ to_agree I ∧ h !! l = Some (v, I).
  Proof.
    rewrite /to_inv_heap /prod_map lookup_fmap. rewrite fmap_Some_equiv.
    intros ([] & Hsome & [Heqv HeqI]); simplify_eq/=; eauto.
  Qed.
End to_inv_heap.

Lemma inv_heap_init (L V : Type) `{Countable L, !invGS_gen hlc Σ, !gen_heapGS L V Σ, !inv_heapGpreS L V Σ} E :
  ⊢ |==> ∃ _ : inv_heapGS L V Σ, |={E}=> inv_heap_inv L V.
Proof.
  iMod (own_alloc (● (to_inv_heap ∅))) as (γ) "H●".
  { rewrite auth_auth_valid. exact: to_inv_heap_valid. }
  iModIntro.
  iExists (Inv_HeapG L V γ).
  iAssert (inv_heap_inv_P (gG := Inv_HeapG L V γ)) with "[H●]" as "P".
  { iExists _. iFrame. done. }
  iApply (inv_alloc inv_heapN E inv_heap_inv_P with "P").
Qed.

Section inv_heap.
  Context {L V : Type} `{Countable L}.
  Context `{!invGS_gen hlc Σ, !gen_heapGS L V Σ, gG: !inv_heapGS L V Σ}.
  Implicit Types (l : L) (v : V) (I : V → Prop).
  Implicit Types (h : gmap L (V * (V -d> PropO))).

  (** * Helpers *)

  Lemma inv_mapsto_lookup_Some l h I :
    l ↦_I □ -∗ own (inv_heap_name gG) (● to_inv_heap h) -∗
    ⌜∃ v I', h !! l = Some (v, I') ∧ ∀ w, I w ↔ I' w ⌝.
  Proof.
    iIntros "Hl_inv H◯".
    iCombine "H◯ Hl_inv" gives %[Hincl Hvalid]%auth_both_valid_discrete.
    iPureIntro.
    move: Hincl; rewrite singleton_included_l; intros ([v' I'] & Hsome & Hincl).
    apply lookup_to_inv_heap_Some_2 in Hsome as (v'' & I'' & _ & HI & Hh).
    move: Hincl; rewrite HI Some_included_total pair_included
      to_agree_included; intros [??]; eauto.
  Qed.

  Lemma inv_mapsto_own_lookup_Some l v h I :
    l ↦_I v -∗ own (inv_heap_name gG) (● to_inv_heap h) -∗
    ⌜ ∃ I', h !! l = Some (v, I') ∧ ∀ w, I w ↔ I' w ⌝.
  Proof.
    iIntros "Hl_inv H●".
    iCombine "H● Hl_inv" gives %[Hincl Hvalid]%auth_both_valid_discrete.
    iPureIntro.
    move: Hincl; rewrite singleton_included_l; intros ([v' I'] & Hsome & Hincl).
    apply lookup_to_inv_heap_Some_2 in Hsome as (v'' & I'' & -> & HI & Hh).
    move: Hincl; rewrite HI Some_included_total pair_included
      Excl_included to_agree_included; intros [-> ?]; eauto.
  Qed.

  (** * Typeclass instances *)

  (* FIXME(Coq #6294): needs new unification
  The uses of [apply:] and [move: ..; rewrite ..] (by lack of [apply: .. in ..])
  in this file are needed because Coq's default unification algorithm fails. *)
  Global Instance inv_mapsto_own_proper l v :
    Proper (pointwise_relation _ iff ==> (≡)) (inv_mapsto_own l v).
  Proof.
    intros I1 I2 ?. rewrite /inv_mapsto_own. do 2 f_equiv.
    apply: singletonM_proper. f_equiv. by apply: to_agree_proper.
  Qed.
  Global Instance inv_mapsto_proper l :
    Proper (pointwise_relation _ iff ==> (≡)) (inv_mapsto l).
  Proof.
    intros I1 I2 ?. rewrite /inv_mapsto. do 2 f_equiv.
    apply: singletonM_proper. f_equiv. by apply: to_agree_proper.
  Qed.

  Global Instance inv_heap_inv_persistent : Persistent (inv_heap_inv L V).
  Proof. apply _. Qed.

  Global Instance inv_mapsto_persistent l I : Persistent (l ↦_I □).
  Proof. apply _. Qed.

  Global Instance inv_mapsto_timeless l I : Timeless (l ↦_I □).
  Proof. apply _. Qed.

  Global Instance inv_mapsto_own_timeless l v I : Timeless (l ↦_I v).
  Proof. apply _. Qed.

  (** * Public lemmas *)

  Lemma make_inv_mapsto l v I E :
    ↑inv_heapN ⊆ E →
    I v →
    inv_heap_inv L V -∗ l ↦ v ={E}=∗ l ↦_I v.
  Proof.
    iIntros (HN HI) "#Hinv Hl".
    iMod (inv_acc_timeless _ inv_heapN with "Hinv") as "[HP Hclose]"; first done.
    iDestruct "HP" as (h) "[H● HsepM]".
    destruct (h !! l) as [v'| ] eqn: Hlookup.
    - (* auth map contains l --> contradiction *)
      iDestruct (big_sepM_lookup with "HsepM") as "[_ Hl']"; first done.
      by iCombine "Hl Hl'" gives %[??].
    - iMod (own_update with "H●") as "[H● H◯]".
      { apply lookup_to_inv_heap_None in Hlookup.
        apply (auth_update_alloc _
          (to_inv_heap (<[l:=(v,I)]> h)) (to_inv_heap ({[l:=(v,I)]}))).
        rewrite to_inv_heap_insert to_inv_heap_singleton.
        by apply: alloc_singleton_local_update. }
      iMod ("Hclose" with "[H● HsepM Hl]").
      + iExists _.
        iDestruct (big_sepM_insert _ _ _ (_,_) with "[$HsepM $Hl]")
          as "HsepM"; auto with iFrame.
      + iModIntro. by rewrite /inv_mapsto_own to_inv_heap_singleton.
  Qed.

  Lemma inv_mapsto_own_inv l v I : l ↦_I v -∗ l ↦_I □.
  Proof.
    apply own_mono, auth_frag_mono. rewrite singleton_included pair_included.
    right. split; [apply: ucmra_unit_least|done].
  Qed.

  (** An accessor to make use of [inv_mapsto_own].
    This opens the invariant *before* consuming [inv_mapsto_own] so that you can use
    this before opening an atomic update that provides [inv_mapsto_own]!. *)
  Lemma inv_mapsto_own_acc_strong E :
    ↑inv_heapN ⊆ E →
    inv_heap_inv L V ={E, E ∖ ↑inv_heapN}=∗ ∀ l v I, l ↦_I v -∗
      (⌜I v⌝ ∗ l ↦ v ∗ (∀ w, ⌜I w ⌝ -∗ l ↦ w ==∗
        inv_mapsto_own l w I ∗ |={E ∖ ↑inv_heapN, E}=> True)).
  Proof.
    iIntros (HN) "#Hinv".
    iMod (inv_acc_timeless _ inv_heapN _ with "Hinv") as "[HP Hclose]"; first done.
    iIntros "!>" (l v I) "Hl_inv".
    iDestruct "HP" as (h) "[H● HsepM]".
    iDestruct (inv_mapsto_own_lookup_Some with "Hl_inv H●") as %(I'&?&HI').
    setoid_rewrite HI'.
    iDestruct (big_sepM_delete with "HsepM") as "[[HI Hl] HsepM]"; first done.
    iIntros "{$HI $Hl}" (w ?) "Hl".
    iMod (own_update_2 with "H● Hl_inv") as "[H● H◯]".
    { apply (auth_update _ _ (<[l := (Excl' w, to_agree I')]> (to_inv_heap h))
             {[l := (Excl' w, to_agree I)]}).
      apply: singleton_local_update.
      { by apply lookup_to_inv_heap_Some. }
      apply: prod_local_update_1. apply: option_local_update.
      apply: exclusive_local_update. done. }
    iDestruct (big_sepM_insert _ _ _ (w, I') with "[$HsepM $Hl //]") as "HsepM".
    { apply lookup_delete. }
    rewrite insert_delete_insert -to_inv_heap_insert. iIntros "!> {$H◯}".
    iApply ("Hclose" with "[H● HsepM]"). iExists _; by iFrame.
  Qed.

  (** Derive a more standard accessor. *)
  Lemma inv_mapsto_own_acc E l v I:
    ↑inv_heapN ⊆ E →
    inv_heap_inv L V -∗ l ↦_I v ={E, E ∖ ↑inv_heapN}=∗
      (⌜I v⌝ ∗ l ↦ v ∗ (∀ w, ⌜I w ⌝ -∗ l ↦ w ={E ∖ ↑inv_heapN, E}=∗ l ↦_I w)).
  Proof.
    iIntros (?) "#Hinv Hl".
    iMod (inv_mapsto_own_acc_strong with "Hinv") as "Hacc"; first done.
    iDestruct ("Hacc" with "Hl") as "(HI & Hl & Hclose)".
    iIntros "!> {$HI $Hl}" (w) "HI Hl".
    iMod ("Hclose" with "HI Hl") as "[$ $]".
  Qed.

  Lemma inv_mapsto_acc l I E :
    ↑inv_heapN ⊆ E →
    inv_heap_inv L V -∗ l ↦_I □ ={E, E ∖ ↑inv_heapN}=∗
    ∃ v, ⌜I v⌝ ∗ l ↦ v ∗ (l ↦ v ={E ∖ ↑inv_heapN, E}=∗ ⌜True⌝).
  Proof.
    iIntros (HN) "#Hinv Hl_inv".
    iMod (inv_acc_timeless _ inv_heapN _ with "Hinv") as "[HP Hclose]"; first done.
    iModIntro.
    iDestruct "HP" as (h) "[H● HsepM]".
    iDestruct (inv_mapsto_lookup_Some with "Hl_inv H●") as %(v&I'&?&HI').
    iDestruct (big_sepM_lookup_acc with "HsepM") as "[[#HI Hl] HsepM]"; first done.
    setoid_rewrite HI'.
    iExists _. iIntros "{$HI $Hl} Hl".
    iMod ("Hclose" with "[H● HsepM Hl]"); last done.
    iExists _. iFrame "H●". iApply ("HsepM" with "[$Hl //]").
  Qed.

End inv_heap.

Typeclasses Opaque inv_heap_inv inv_mapsto inv_mapsto_own.


Require Import Bedrock PreAutoSep Sys.
Import XCAP.

Definition goodSize' (n : nat) := (N.of_nat n < 1 + Npow2 32)%N.

Lemma wordToNat_ninj : forall sz (u v : word sz),
  u <> v
  -> wordToNat u <> wordToNat v.
  intros; intro; apply H.
  assert (natToWord sz (wordToNat u) = natToWord sz (wordToNat v)) by congruence.
  repeat rewrite natToWord_wordToNat in H1.
  assumption.
Qed.

Lemma get_memoryIn' : forall m w init,
  (wordToNat w < init)%nat
  -> goodSize' init
  -> smem_get' (allWordsUpto 32 init) w (memoryIn' m _) = m w.
  induction init; simpl; intuition.
  destruct (H.addr_dec $(init) w).
  unfold H.mem_get, ReadByte.
  congruence.
  apply IHinit.
  apply wordToNat_ninj in n.
  rewrite wordToNat_natToWord_idempotent in n.
  omega.
  generalize H0; clear.
  unfold goodSize'.
  generalize (Npow2 32); intros.
  apply Nlt_out in H0.
  rewrite N2Nat.inj_add in H0.
  autorewrite with N in *.
  pre_nomega.
  simpl in *.
  omega.
  generalize H0; clear.
  unfold goodSize'.
  generalize (Npow2 32).
  intros.
  nomega.
Qed.

Lemma pow2_N : forall n,
  N.of_nat (pow2 n) = Npow2 n.
  intros.
  assert (N.to_nat (N.of_nat (pow2 n)) = N.to_nat (Npow2 n)).
  autorewrite with N.
  symmetry; apply Npow2_nat.
  assert (N.of_nat (N.to_nat (N.of_nat (pow2 n))) = N.of_nat (N.to_nat (Npow2 n))) by congruence.
  autorewrite with N in *.
  assumption.
Qed.

Lemma get_memoryIn : forall m w,
  smem_get w (memoryIn m) = m w.
  intros.
  unfold smem_get, memoryIn, HT.memoryIn, H.all_addr.
  rewrite allWords_eq.
  apply get_memoryIn'.
  apply wordToNat_bound.
  hnf.
  rewrite pow2_N.
  reflexivity.
Qed.

Require Import DepList.

Fixpoint smem_put ls (sm : smem' ls) (w : W) (v : B) : smem' ls :=
  match sm with
    | HNil => HNil
    | HCons w' _ v' sm' =>
      HCons (if H.addr_dec w w' then Some v else v') (smem_put _ sm' w v)
  end.

Fixpoint smem_clear ls (sm : smem' ls) (w : W) : smem' ls :=
  match sm with
    | HNil => HNil
    | HCons w' _ v sm' =>
      HCons (if H.addr_dec w w' then None else v) (smem_clear _ sm' w)
  end.

Fixpoint smem_graft (sm sm' : smem) (p : W) (len : nat) : smem :=
  match len with
    | O => sm
    | S len' =>
      match smem_get p sm' with
        | None => sm
        | Some v => smem_put _ (smem_graft sm sm' (p ^+ $1) len') p v
      end
  end.

Section OpSem.
  Variable m : module.
  Variable stn : settings.
  Variable prog : program.

  Hypothesis inj : forall l1 l2 w, Labels stn l1 = Some w
    -> Labels stn l2 = Some w
    -> l1 = l2.

  Definition labelSys' (l_pre : string * spec) :=
    (Global (fst l_pre), Precondition (snd l_pre) None).

  Definition labelSys (l : LabelMap.key) (pre : assert) :=
    fst l = "sys"
    /\ In (snd l, pre) (map labelSys' (
      ("abort", abortS)
      :: ("printInt", printIntS)
      :: ("listen", listenS)
      :: ("accept", acceptS)
      :: ("read", readS)
      :: ("write", writeS)
      :: ("declare", declareS)
      :: ("wait", waitS)
      :: ("close", closeS)
      :: nil)).

  Hypothesis impSys :
    LabelMap.fold (fun l pre P => labelSys l pre /\ P) (Imports m) True.

  Lemma preserve : forall (ls : list (LabelMap.key * assert)) Q,
    fold_left (fun P p => labelSys (fst p) (snd p) /\ P) ls Q
    -> Q.
    induction ls; simpl in *; intuition.
    apply IHls in H; tauto.
  Qed.

  Theorem impSys' : forall l pre, LabelMap.MapsTo l pre (Imports m)
    -> labelSys l pre.
    rewrite LabelMap.fold_1 in impSys; intros.
    apply LabelMap.elements_1 in H.
    generalize dependent True.
    clear impSys; induction H; simpl in *; intuition.

    hnf in H; simpl in H; intuition subst.
    apply preserve in impSys; tauto.

    eauto.
  Qed.

  Hypothesis agree : forall l pre bl, LabelMap.MapsTo l (pre, bl) (Blocks m)
    -> exists w, Labels stn l = Some w
      /\ prog w = Some bl.

  Hypothesis agreeImp : forall l pre, LabelMap.MapsTo l pre (Imports m)
    -> exists w, Labels stn l = Some w
      /\ prog w = None.

  Hypothesis omitImp : forall l w,
    Labels stn ("sys", l) = Some w
    -> prog w = None.

  Hypothesis ok : moduleOk m.

  Hint Constructors reachable sys_step sys_reachable.

  Definition goodState (st : state') :=
    exists l pre, Labels stn l = Some (fst st)
      /\ interp (specs m stn) (pre (stn, snd st))
      /\ (LabelMap.MapsTo l pre (Imports m)
        \/ exists bl, LabelMap.MapsTo l (pre, bl) (Blocks m)).

  Lemma locals_mapped' : forall specs stn st vs ns sp P,
    interp specs (![array (toArray ns vs) sp * P] (stn, st))
    -> mapped sp (length ns * 4) (Mem st).
    induction ns; simpl; intuition; hnf; intuition.
    unfold array in H.
    assert (interp specs (![ptsto32m' nil sp 0 (vs a :: toArray ns vs) * P] (stn0, st))).
    eapply ILTacCommon.interp_interp_himp; eauto.
    eapply himp_star_frame; [ apply Arrays.ptsto32m'_in | reflexivity ].
    clear H.
    simpl in *.
    assert (n < 4 \/ (n >= 4 /\ n - 4 < length ns * 4))%nat by omega.
    intuition.
    rewrite sepFormula_eq in H2; propxFo.
    unfold smem_get_word, H.footprint_w in H6.
    repeat match type of H6 with
             | match ?E with None => _ | _ => _ end = _ => case_eq E; intros;
               try match goal with
                     | [ H : _ = _ |- _ ] => rewrite H in H6
                   end; try discriminate
           end.
    inversion H3; clear H3; subst.

    Lemma unsplit_smem_get' : forall a v ls m m',
      smem_get' ls a m = Some v
      -> smem_get' ls a (join' ls m m') = Some v.
      induction ls; simpl; intuition.
      destruct (H.addr_dec a0 a); subst.
      rewrite H; auto.
      eauto.
    Qed.

    Lemma unsplit_smem_get : forall a m v m0 m1,
      smem_get a m = Some v
      -> split m0 m m1
        -> smem_get a m0 = Some v.
      unfold split; intuition subst; apply unsplit_smem_get'; auto.
    Qed.

    do 2 (eapply unsplit_smem_get in H11; eauto).
    rewrite get_memoryIn in H11.
    replace (sp ^+ $0 ^+ $3) with (sp ^+ $3) in * by words.
    congruence.

    inversion H13; clear H13; subst.
    do 2 (eapply unsplit_smem_get in H10; eauto).
    rewrite get_memoryIn in H10.
    replace (sp ^+ $0 ^+ $2) with (sp ^+ $2) in * by words.
    congruence.

    inversion H12; clear H12; subst.
    do 2 (eapply unsplit_smem_get in H9; eauto).
    rewrite get_memoryIn in H9.
    replace (sp ^+ $0 ^+ $1) with (sp ^+ $1) in * by words.
    congruence.

    inversion H13; clear H13; subst.
    do 2 (eapply unsplit_smem_get in H; eauto).
    rewrite get_memoryIn in H.
    congruence.

    inversion H12.

    assert (interp specs (![array (toArray ns vs) (sp ^+ $4) * ((sp ^+ $ (0)) =*> vs a * P)] (stn0, st))).
    eapply ILTacCommon.interp_interp_himp; eauto.
    clear.

    Lemma comeOnOut : forall P Q R,
      P * Q * R ===> Q * (P * R).
      clear; sepLemma.
    Qed.

    etransitivity; [ apply comeOnOut | ].
    apply Himp_star_frame; [ | apply Himp_refl ].
    eapply Himp_trans; [ | apply ptsto32m'_out ].
    apply ptsto32m'_shift_base'; auto.

    clear H2.
    apply IHns in H3.
    hnf in H3.
    eapply H3.
    eauto.
    replace (sp ^+ $4 ^+ $(n - 4)) with (sp ^+ $(n)); auto.
    rewrite natToW_minus by auto.
    unfold natToW.
    W_eq.
  Qed.

  Lemma locals_mapped : forall specs ns vs res sp stn st P,
    interp specs (![locals ns vs res sp * P] (stn, st))
    -> mapped sp (length ns * 4) (Mem st).
    unfold locals; intros.
    assert (interp specs
      (![array (toArray ns vs) sp * ([|NoDup ns|] *
        (sp ^+ $ (Datatypes.length ns * 4)) =?> res * P)]
      (stn0, st))).
    generalize H; clear; intros; step auto_ext.
    eapply locals_mapped'; eauto.
  Qed.

  Lemma array8_mapped : forall specs stn bs p m,
    interp specs (array8 bs p stn m)
    -> forall n, (n < length bs)%nat
      -> smem_get (p ^+ $(n)) m <> None.
    induction bs; simpl; post.
    intuition.
    destruct n.
    replace (p ^+ $0) with p in H1 by words.
    eapply split_smem_get in H2; eauto.
    rewrite H1 in H2; discriminate.
    eapply IHbs in H4; try tauto.
    instantiate (1 := n); auto.
    replace (p ^+ $1 ^+ $(n)) with (p ^+ $(S n))
      by (rewrite natToW_S; unfold natToW; W_eq).
    case_eq (smem_get (p ^+ $(S n)) x0); intros; auto.
    eapply split_smem_get in H2; eauto.
    congruence.
  Qed.

  Lemma bytes_mapped : forall specs p sz stn st P,
    interp specs (![p =?>8 sz * P] (stn, st))
    -> mapped p sz (Mem st).
    unfold buffer; rewrite sepFormula_eq; post.
    hnf; intros.
    eapply split_comm in H1; eapply split_semp in H1; eauto; subst.
    eapply array8_mapped in H; eauto.
    case_eq (smem_get (p ^+ $(n)) x2); intros; try congruence.
    eapply split_smem_get in H0; eauto.
    rewrite get_memoryIn in H0.
    congruence.
  Qed.

  Lemma prove_ReadWord : forall stn m (p : W) v st,
    evalInstrs stn st (Assign Rv (LvMem p) :: nil) <> None
    -> (forall st', evalInstrs stn st (Assign Rv (LvMem p) :: nil) = Some st'
      -> Regs st' Rv = v)
    -> Mem st = m
    -> ReadWord stn m p = Some v.
    intros.
    match goal with
      | [ H : (?X <> None)%type |- _ ] => case_eq X; intros; try tauto
    end.
    Transparent evalInstrs.
    simpl in *.
    subst.
    destruct (ReadWord stn0 (Mem st) p); simpl in *; try congruence.
    injection H2; clear H2; intros; subst; auto.
    specialize (H0 _ eq_refl).
    subst; auto.
  Qed.

  Lemma evalInstrs_slot : forall stn st n,
    evalInstrs stn st (Assign Rv (LvMem (Imm (Regs st Sp ^+ $(n)))) :: nil)
    = evalInstrs stn st (Assign Rv (LvMem (Sp + $(n))%loc) :: nil).
    auto.
  Qed.

  Opaque evalInstrs.

  Lemma specs_hit : forall w pre,
    specs m stn w = Some pre
    -> exists l, Labels stn l = Some w
      /\ (LabelMap.MapsTo l pre (Imports m)
        \/ exists bl, LabelMap.MapsTo l (pre, bl) (Blocks m)).
    intros.
    apply specs_hit in H; post; eauto.
    apply specs'_hit in H0; post; eauto.
  Qed.

  Lemma smem_get'_emp : forall p ls,
    smem_get' ls p (smem_emp' ls) = None.
    induction ls; simpl; intuition.
    destruct (H.addr_dec a p); auto.
  Qed.

  Lemma smem_get_emp : forall p,
    smem_get p smem_emp = None.
    intros; apply smem_get'_emp.
  Qed.

  Lemma must_be' : forall p ls m1 m2,
    smem_get' ls p m1 = None
    -> smem_get' ls p m2 = None
    -> smem_get' ls p (join' ls m1 m2) = None.
    clear; induction ls; simpl; intuition.
    destruct (H.addr_dec a p); subst; intuition.
    rewrite H; auto.
  Qed.

  Lemma must_be : forall m m1 m2 p,
    split m m1 m2
    -> smem_get p m <> None
    -> smem_get p m1 = None
    -> smem_get p m2 <> None.
    destruct 1; intuition subst.
    unfold smem_get, join in H1.
    rewrite must_be' in H1; eauto.
  Qed.

  Lemma characterize_array8_fwd : forall specs stn bs base m m',
    interp specs (array8 bs base stn m)
    -> (forall p, (forall n, (n < length bs)%nat -> p <> base ^+ $(n))
      -> smem_get p m' = smem_get p m)
    -> (forall p, smem_get p m <> None ->
      exists n, (n < length bs)%nat /\ p = base ^+ $(n)).
    clear; induction bs; simpl; propxFo.

    hnf in H3; subst.
    rewrite smem_get_emp in H1; tauto.
    destruct (weq p base); subst.
    exists 0; intuition.
    unfold H.addr in *; W_eq.

    assert (smem_get p x0 <> None).
    eapply must_be; eauto.
    case_eq (smem_get p x0); intros; try congruence.
    clear H.
    edestruct IHbs; eauto.
    instantiate (1 := p); congruence.
    intuition subst.
    exists (S x1); intuition.
    change ($(S x1)) with (natToW (S x1)).
    rewrite (natToW_S x1).
    unfold natToW.
    unfold H.addr in *.
    W_eq.
  Qed.

  Lemma split_None : forall p m m1 m2,
    smem_get p m = None
    -> split m m1 m2
    -> smem_get p m2 = None.
    intros; case_eq (smem_get p m2); intros; auto.
    eapply split_smem_get in H0; eauto.
    congruence.
  Qed.

  Lemma split'_None' : forall p ls m1 m2,
    smem_get' ls p m1 = None
    -> smem_get' ls p m2 = smem_get' ls p (join' ls m1 m2).
    induction ls; simpl; intuition.
    destruct (H.addr_dec a p); subst; intuition.
    rewrite H; auto.
  Qed.

  Lemma split_None' : forall p m m1 m2,
    split m m1 m2
    -> smem_get p m1 = None
    -> smem_get p m2 = smem_get p m.
    destruct 1; subst; apply split'_None'.
  Qed.

  Lemma characterize_array8_bwd : forall specs stn bs base m,
    interp specs (array8 bs base stn m)
    -> (forall n, (n < length bs)%nat
      -> smem_get (base ^+ $(n)) m <> None).
    induction bs; simpl; propxFo.

    intuition.

    destruct n.
    erewrite split_smem_get in H1.
    discriminate.
    eauto.
    replace (base ^+ $0) with base by words.
    eauto.

    eapply IHbs.
    eauto.
    instantiate (1 := n); omega.
    replace (base ^+ $1 ^+ $(n)) with (base ^+ $(S n))
      by (rewrite natToW_S; unfold natToW; words).
    eauto using split_None.
  Qed.

  Lemma semp_eta' : forall ls, NoDup ls
    -> forall m,
      (forall p, In p ls -> smem_get' ls p m = None)
      -> m = smem_emp' ls.
    clear; induction 1; simpl; intuition.
    rewrite (hlist_nil_only _ m); auto.
    rewrite (hlist_eta _ m); f_equal.
    specialize (H1 x); destruct (H.addr_dec x x); tauto.
    apply IHNoDup; intros.
    specialize (H1 p); destruct (H.addr_dec x p); subst; eauto; tauto.
  Qed.

  Lemma semp_eta : forall m,
    (forall p, smem_get p m = None)
    -> semp m.
    intros; apply semp_eta'; auto.
    apply H.NoDup_all_addr.
  Qed.

  Lemma get_clear_ne' : forall a a' ls (sm : smem' ls),
    a <> a'
    -> smem_get' ls a (smem_clear _ sm a') = smem_get' ls a sm.
    induction sm; simpl; intuition.
    destruct (H.addr_dec x a); auto.
    destruct (H.addr_dec a' x); congruence.
  Qed.

  Lemma get_clear_ne : forall a a' sm,
    a <> a'
    -> smem_get a (smem_clear _ sm a') = smem_get a sm.
    intros; apply get_clear_ne'; auto.
  Qed.

  Lemma get_clear_eq' : forall a ls (sm : smem' ls),
    smem_get' ls a (smem_clear _ sm a) = None.
    induction sm; simpl; intuition.
    destruct (H.addr_dec x a); auto.
    destruct (H.addr_dec a x); congruence.
  Qed.

  Lemma get_clear_eq : forall a sm,
    smem_get a (smem_clear _ sm a) = None.
    intros; apply get_clear_eq'.
  Qed.

  Hint Rewrite get_clear_eq get_clear_ne
    using solve [ assumption | W_neq ] : get.

  Lemma get_put_eq' : forall a v ls (sm : smem' ls),
    In a ls
    -> smem_get' ls a (smem_put _ sm a v) = Some v.
    induction sm; simpl; intuition.
    subst.
    destruct (H.addr_dec a a); intuition idtac.
    destruct (H.addr_dec x a); intuition idtac.
    subst.
    destruct (H.addr_dec a a); intuition idtac.
  Qed.

  Lemma allWordsUpto_universal : forall width init w,
    (wordToNat w < init)%nat
    -> (init <= pow2 width)%nat
    -> In w (allWordsUpto width init).
    induction init; simpl; intuition.
    destruct (weq w $(init)); subst; auto; right.
    assert (wordToNat w <> init).
    intro; apply n.
    subst.
    symmetry; apply natToWord_wordToNat.
    auto.
  Qed.

  Lemma allWords_universal : forall sz w,
    In w (allWords sz).
    rewrite allWords_eq; intros; apply allWordsUpto_universal.
    apply wordToNat_bound.
    auto.
  Qed.

  Lemma get_put_eq : forall a v sm,
    smem_get a (smem_put _ sm a v) = Some v.
    intros; apply get_put_eq'.
    apply allWords_universal.
  Qed.

  Lemma get_put_ne' : forall a a' v ls (sm : smem' ls),
    a <> a'
    -> smem_get' ls a (smem_put _ sm a' v) = smem_get' ls a sm.
    induction sm; simpl; intuition.
    destruct (H.addr_dec a' x); intuition idtac.
    destruct (H.addr_dec x a); intuition idtac.
    congruence.
    destruct (H.addr_dec x a); intuition idtac.
  Qed.

  Lemma get_put_ne : forall a a' v sm,
    a <> a'
    -> smem_get a (smem_put _ sm a' v) = smem_get a sm.
    intros; apply get_put_ne'; auto.
  Qed.

  Hint Rewrite smem_get_emp get_put_eq get_put_ne
    using solve [ assumption | W_neq ] : get.

  Lemma join_None' : forall a ls sm1 sm2,
    smem_get' ls a sm1 = None
    -> smem_get' ls a (join' ls sm1 sm2) = smem_get' ls a sm2.
    induction sm1; simpl; intuition.
    destruct (H.addr_dec x a); subst; auto.
  Qed.

  Lemma join_None : forall a sm1 sm2,
    smem_get a sm1 = None
    -> smem_get a (join sm1 sm2) = smem_get a sm2.
    intros; apply join_None'; auto.
  Qed.

  Lemma join_Some' : forall a v ls sm1 sm2,
    smem_get' ls a sm1 = Some v
    -> smem_get' ls a (join' ls sm1 sm2) = Some v.
    induction sm1; simpl; intuition.
    destruct (H.addr_dec x a); subst; auto.
  Qed.

  Lemma join_Some : forall a v sm1 sm2,
    smem_get a sm1 = Some v
    -> smem_get a (join sm1 sm2) = Some v.
    intros; apply join_Some'; auto.
  Qed.

  Lemma disjoint_get' : forall ls sm1 sm2,
    NoDup ls
    -> List.Forall (fun w => smem_get' ls w sm1 <> None -> smem_get' ls w sm2 <> None -> False) ls
    -> disjoint' ls sm1 sm2.
    induction sm1; simpl; intuition; rewrite (hlist_eta _ sm2) in *; simpl in *.
    inversion H; clear H; subst.
    inversion H0; clear H0; subst.
    destruct (H.addr_dec x x); try tauto.
    destruct b; auto.
    destruct (hlist_hd sm2); auto.
    intuition discriminate.
    inversion H; clear H; subst.
    inversion H0; clear H0; subst.
    apply IHsm1; intros; auto.
    eapply Forall_weaken'; eauto.
    simpl; intros.
    destruct (H.addr_dec x x0); subst; tauto.
  Qed.

  Lemma disjoint_get : forall sm1 sm2,
    (forall w, smem_get w sm1 <> None -> smem_get w sm2 <> None -> False)
    -> disjoint sm1 sm2.
    intros; apply disjoint_get'.
    apply BedrockHeap.NoDup_all_addr.
    apply Forall_forall; intros.
    eauto.
  Qed.

  Lemma disjoint_get_fwd' : forall ls sm1 sm2,
    disjoint' ls sm1 sm2
    -> NoDup ls
    -> List.Forall (fun w => smem_get' ls w sm1 <> None -> smem_get' ls w sm2 <> None -> False) ls.
    induction sm1; simpl; intuition; rewrite (hlist_eta _ sm2) in *; simpl in *;
      subst; constructor; simpl.
    destruct (H.addr_dec x x); tauto.
    inversion H0; clear H0; subst.
    eapply Forall_weaken'; try apply IHsm1.
    eauto.
    auto.
    simpl; intros.
    destruct (H.addr_dec x x0); subst; tauto.
    destruct (H.addr_dec x x); tauto.
    inversion H0; clear H0; subst.
    eapply Forall_weaken'; try apply IHsm1.
    eauto.
    auto.
    simpl; intros.
    destruct (H.addr_dec x x0); subst; tauto.
  Qed.

  Lemma disjoint_get_fwd : forall sm1 sm2,
    disjoint sm1 sm2
    -> (forall w, smem_get w sm1 <> None -> smem_get w sm2 <> None -> False).
    intros; eapply disjoint_get_fwd' in H; try apply BedrockHeap.NoDup_all_addr.
    assert (In w H.all_addr) by apply allWords_universal.
    generalize (proj1 (Forall_forall _ _) H _ H2); tauto.
  Qed.

  Lemma smem_eta : forall ls (sm sm' : smem' ls),
    NoDup ls
    -> List.Forall (fun w => smem_get' ls w sm = smem_get' ls w sm') ls
    -> sm = sm'.
    induction sm; simpl; intuition.
    rewrite hlist_nil; auto.
    inversion H0; clear H0; subst.
    inversion H; clear H; subst.
    destruct (H.addr_dec x x); intuition idtac; subst.
    rewrite (hlist_eta _ sm'); f_equal.
    apply IHsm; auto.
    eapply Forall_weaken'; eauto.
    simpl; intros.
    destruct (H.addr_dec x x0); subst; tauto.
  Qed.

  Lemma split_put_clear : forall sm sm1 sm2 a v,
    split sm sm1 sm2
    -> smem_get a sm2 = Some v
    -> split sm (smem_put _ sm1 a v) (smem_clear _ sm2 a).
    unfold split; intuition subst.
    apply disjoint_get; intros.
    destruct (weq w a); subst.
    autorewrite with get in *; tauto.
    autorewrite with get in *.
    eapply disjoint_get_fwd in H1; eassumption.

    apply smem_eta; try apply BedrockHeap.NoDup_all_addr.
    apply Forall_forall; intros.
    destruct (weq x a); subst.
    rewrite join_None.
    erewrite join_Some.
    eauto.
    autorewrite with get; reflexivity.
    case_eq (smem_get a sm1); auto; intros.
    eapply disjoint_get_fwd in H1; try eassumption.
    tauto.
    instantiate (1 := a); congruence.
    congruence.

    case_eq (smem_get x sm1); intros.
    erewrite join_Some.
    erewrite join_Some.
    2: autorewrite with get; eassumption.
    2: eassumption.
    reflexivity.

    rewrite join_None.
    rewrite join_None.
    autorewrite with get; reflexivity.
    autorewrite with get; assumption.
    assumption.
  Qed.

  Lemma recharacterize_array8 : forall specs stn sz base m,
    (forall n, (0 < n < sz)%nat
      -> base ^+ $(n) <> base)
    -> (forall n, (n < sz)%nat
      -> smem_get (base ^+ $(n)) m <> None)
    -> (forall p, smem_get p m <> None ->
      exists n, (n < sz)%nat /\ p = base ^+ $(n))
    -> exists bs, length bs = sz /\ interp specs (array8 bs base stn m).
    clear; induction sz; simpl; intuition.

    exists nil; simpl; propxFo.
    apply semp_eta.
    intros.
    specialize (H1 p).
    destruct (smem_get p m); auto.
    destruct H1.
    congruence.
    intuition.

    generalize (H0 0); replace (base ^+ $0) with base by words;
      case_eq (smem_get base m); intros; try solve [ elimtype False; eauto ].
    clear H3.
    edestruct IHsz.
    instantiate (1 := base ^+ $1).
    intros.
    replace (base ^+ $ (1) ^+ $ (n)) with (base ^+ natToW (S n)) in *
      by (rewrite natToW_S; unfold natToW; W_eq).
    intros.
    eapply H.
    instantiate (1 := n); auto.
    apply (f_equal (fun x => x ^- $1)) in H4.
    rewrite natToW_S in H4.
    unfold natToW in H4.
    replace (base ^+ ($1 ^+ $(n)) ^- $1) with (base ^+ $(n)) in H4 by W_eq.
    replace (base ^+ $1 ^- $1) with base in H4 by W_eq.
    auto.

    instantiate (1 := smem_clear _ m base).
    intros.
    replace (base ^+ $ (1) ^+ $ (n)) with (base ^+ natToW (S n)) in H4
      by (rewrite natToW_S; unfold natToW; W_eq).
    rewrite get_clear_ne in H4.
    apply H0 with (S n).
    auto.
    auto.
    intro.
    eapply H.
    2: eauto.
    auto.

    intros.
    destruct (weq p base); subst.
    rewrite get_clear_eq in H3; tauto.
    rewrite get_clear_ne in H3; auto.
    apply H1 in H3.
    propxFo; subst.
    destruct x.
    elimtype False; apply n.
    words.
    exists x; intuition.
    rewrite natToW_S.
    unfold natToW.
    unfold H.addr in *.
    W_eq.

    intuition subst; simpl; exists (b :: x); propxFo.
    exists (smem_put _ smem_emp base b).
    exists (smem_clear _ m base).
    descend.
    apply split_put_clear.
    apply split_a_semp_a.
    auto.
    apply get_put_eq.
    rewrite get_put_ne; auto.
    autorewrite with get; auto.
  Qed.

  Lemma disjoint_eta' : forall ls, NoDup ls
    -> forall m1 m2,
      (forall p v1 v2, In p ls
        -> smem_get' ls p m1 = Some v1
        -> smem_get' ls p m2 = Some v2
        -> False)
      -> disjoint' ls m1 m2.
    induction 1; simpl; intuition auto 1.
    specialize (H1 x); destruct (H.addr_dec x x); try tauto.
    destruct (hlist_hd m1); auto; destruct (hlist_hd m2); auto.
    elimtype False; eauto.

    apply IHNoDup; intros.
    specialize (H1 p).
    destruct (H.addr_dec x p); try congruence.
    eauto.
  Qed.

  Lemma disjoint_eta : forall m1 m2,
    (forall p v1 v2, smem_get p m1 = Some v1
      -> smem_get p m2 = Some v2
      -> False)
    -> disjoint m1 m2.
    intros; apply disjoint_eta'.
    apply H.NoDup_all_addr.
    eauto.
  Qed.

  Lemma get_graft : forall p0 v sz m m' p,
    smem_get p0 (smem_graft m m' p sz) = Some v
    -> smem_get p0 m = Some v \/ (exists n, p0 = p ^+ $(n)
      /\ (n < sz)%nat
      /\ smem_get p0 m' = Some v).
    clear; induction sz; simpl; intuition auto 1.
    case_eq (smem_get p m'); intros;
      match goal with
        | [ H : _ = _ |- _ ] => rewrite H in *; try congruence; eauto
      end.
    destruct (weq p0 p); subst.
    rewrite get_put_eq in *.
    right; exists 0; intuition.
    unfold H.addr in *; W_eq.
    rewrite get_put_ne in *; eauto.
    destruct (IHsz _ _ _ H) as [ | [ ? [ ] ] ]; subst; intuition eauto.
    right; exists (S x); intuition.
    unfold H.addr in *.
    change ($ (S x)) with (natToW (S x)).
    rewrite (natToW_S x).
    unfold natToW in *; words.
  Qed.

  Lemma disjoint_not_both' : forall p v ls m1 m2,
    disjoint' ls m1 m2
    -> smem_get' ls p m2 = Some v
    -> smem_get' ls p m1 = None.
    clear; induction ls; simpl; intuition.

    destruct (H.addr_dec a p); eauto.

    destruct (H.addr_dec a p); eauto; congruence.
  Qed.

  Lemma disjoint_not_both : forall m1 m2 p v,
    disjoint m1 m2
    -> smem_get p m2 = Some v
    -> smem_get p m1 = None.
    intros; eapply disjoint_not_both'; eauto.
  Qed.

  Lemma smem_canon' : forall ls, NoDup ls
    -> forall m1 m2,
      (forall p, In p ls -> smem_get' ls p m1 = smem_get' ls p m2)
      -> m1 = m2.
    clear; induction 1; simpl; intuition.
    rewrite (hlist_nil_only _ m1); rewrite (hlist_nil_only _ m2); auto.
    rewrite (hlist_eta _ m1); rewrite (hlist_eta _ m2).
    f_equal.
    specialize (H1 x); destruct (H.addr_dec x x); tauto.
    apply IHNoDup; intros.
    specialize (H1 p).
    destruct (H.addr_dec x p).
    congruence.
    auto.
  Qed.

  Lemma smem_canon : forall m1 m2,
    (forall p, smem_get p m1 = smem_get p m2)
    -> m1 = m2.
    intros; apply smem_canon'.
    apply H.NoDup_all_addr.
    auto.
  Qed.

  Fixpoint smem_minus' ls : smem' ls -> smem' ls -> smem' ls :=
    match ls with
      | nil => fun sm _ => sm
      | a :: ls' => fun sm sm' =>
        HCons match hlist_hd sm' with
                | Some _ => None
                | _ => hlist_hd sm
              end (smem_minus' _ (hlist_tl sm) (hlist_tl sm'))
    end.

  Definition smem_minus (sm sm' : smem) := smem_minus' _ sm sm'.

  Lemma disjoint_minus' : forall ls, NoDup ls
    -> forall m m',
      (forall p v, In p ls
        -> smem_get' ls p m' = Some v -> smem_get' ls p m = Some v)
      -> disjoint' ls (smem_minus' _ m m') m'.
    clear; induction 1; simpl; intuition.
    specialize (H1 x).
    destruct (H.addr_dec x x); try tauto.
    destruct (hlist_hd m'); eauto.
    apply IHNoDup; intros.
    specialize (H1 p); destruct (H.addr_dec x p); try congruence.
    eauto.
  Qed.

  Lemma disjoint_minus : forall m m',
    (forall p v, smem_get p m' = Some v -> smem_get p m = Some v)
    -> disjoint (smem_minus' _ m m') m'.
    intros; apply disjoint_minus'; auto.
    apply H.NoDup_all_addr.
  Qed.

  Lemma join_minus' : forall ls, NoDup ls
    -> forall m m',
      (forall p v, In p ls
        -> smem_get' ls p m' = Some v -> smem_get' ls p m = Some v)
      -> m = join' ls (smem_minus' _ m m') m'.
    clear; induction 1; simpl; intuition.
    rewrite (hlist_nil_only _ m); auto.
    rewrite (hlist_eta _ m); simpl; f_equal.
    specialize (H1 x); destruct (H.addr_dec x x); try tauto.
    destruct (hlist_hd m'); eauto.
    destruct (hlist_hd m); auto.

    apply IHNoDup; intros.
    specialize (H1 p); destruct (H.addr_dec x p); subst.
    tauto.
    eauto.
  Qed.

  Lemma join_minus : forall m m',
    (forall p v, smem_get p m' = Some v -> smem_get p m = Some v)
    -> m = join (smem_minus' _ m m') m'.
    intros; apply join_minus'; auto.
    apply H.NoDup_all_addr.
  Qed.

  Lemma split_minus : forall m m',
    (forall p v, smem_get p m' = Some v -> smem_get p m = Some v)
    -> split m (smem_minus m m') m'.
    unfold split; intuition subst; auto using disjoint_minus, join_minus.
  Qed.

  Lemma no_overlap' : forall p v1 v2 ls m1 m2,
    disjoint' ls m1 m2
    -> In p ls
    -> smem_get' ls p m1 = Some v1
    -> smem_get' ls p m2 = Some v2
    -> False.
    induction ls; simpl; intuition subst.
    destruct (H.addr_dec p p); try tauto; congruence.
    destruct (H.addr_dec p p); try tauto; congruence.
    destruct (H.addr_dec a p); eauto; congruence.
    destruct (H.addr_dec a p); eauto; congruence.
  Qed.

  Lemma no_overlap : forall m1 m2 p v1 v2,
    disjoint m1 m2
    -> smem_get p m1 = Some v1
    -> smem_get p m2 = Some v2
    -> False.
    intros; eapply no_overlap'; eauto.
    apply allWords_universal.
  Qed.

  Lemma not_zero : forall sz n,
    (0 < n < pow2 sz)%nat
    -> natToWord sz n <> wzero sz.
    intros; intro.
    apply (f_equal (@wordToNat _)) in H0.
    rewrite wordToNat_natToWord_idempotent in H0.
    subst.
    rewrite roundTrip_0 in H.
    omega.
    pre_nomega.
    rewrite Npow2_nat.
    auto.
  Qed.

  Lemma tickle_bytes : forall specs p sz P stn st st',
    interp specs (![ p =?>8 sz * P] (stn, st))
    -> onlyChange p sz (Mem st) (Mem st')
    -> interp specs (![ p =?>8 sz * P] (stn, st')).
    clear; unfold buffer; rewrite sepFormula_eq.
    intros.
    apply simplify_fwd in H; simpl in *.
    repeat match goal with
             | [ H : Logic.ex _ |- _ ] => destruct H
             | [ H : _ /\ _ |- _ ] => destruct H
           end.
    apply simplify_bwd in H3.
    hnf in H5; subst.
    apply split_comm in H1; apply split_semp in H1; try reflexivity; subst.

    edestruct recharacterize_array8.

    instantiate (1 := p).
    instantiate (1 := length x1).
    intros.
    apply word_neq.
    replace (p ^+ $(n) ^- p) with (natToW n).
    apply not_zero.
    eapply array8_bound in H3.
    generalize dependent 32.
    intros.
    omega.
    unfold H.addr, natToW in *; W_eq.

    instantiate (1 := smem_minus (memoryIn (Mem st')) x0).
    intros.
    eapply characterize_array8_bwd in H3; eauto.

    Lemma get_minus_out' : forall p ls m1 m2,
      smem_get' ls p m2 = None
      -> smem_get' ls p (smem_minus' _ m1 m2) = smem_get' ls p m1.
      clear; induction ls; simpl; intuition.
      destruct (H.addr_dec a p); intuition.
      rewrite H; auto.
    Qed.

    Lemma get_minus_out : forall p m1 m2,
      smem_get p m2 = None
      -> smem_get p (smem_minus m1 m2) = smem_get p m1.
      intros; apply get_minus_out'; auto.
    Qed.

    Lemma get_minus_in' : forall p ls m1 m2,
      smem_get' ls p m2 <> None
      -> smem_get' ls p (smem_minus' _ m1 m2) = None.
      clear; induction ls; simpl; intuition.
      destruct (H.addr_dec a p); intuition.
      destruct (hlist_hd m2); tauto.
    Qed.

    Lemma get_minus_in : forall p m1 m2,
      smem_get p m2 <> None
      -> smem_get p (smem_minus m1 m2) = None.
      intros; apply get_minus_in'; auto.
    Qed.

    rewrite get_minus_out.
    case_eq (smem_get (p ^+ $(n)) x2); intros; try congruence.
    eapply unsplit_smem_get in H4; eauto.
    repeat rewrite get_memoryIn in *.
    destruct H0.
    specialize (SameMapped (p ^+ $(n))).
    intuition.

    case_eq (smem_get (p ^+ $ (n)) x2); intros; try congruence.
    case_eq (smem_get (p ^+ $ (n)) x0); intros; try congruence.
    destruct H.
    elimtype False; eapply no_overlap; eauto.

    intros.
    destruct H0.
    eapply characterize_array8_fwd; eauto.
    case_eq (smem_get p0 x0); intros.
    rewrite get_minus_in in H1; congruence.
    rewrite get_minus_out in H1 by congruence.
    assert (smem_get p0 (memoryIn (Mem st)) <> None).
    repeat rewrite get_memoryIn in *.
    specialize (SameMapped p0); intuition.
    eapply must_be; eauto; apply split_comm; auto.

    intuition.
    propxFo.
    descend.
    apply split_minus; intros.
    assert (smem_get p0 (memoryIn (Mem st)) = Some v)
      by (eapply split_smem_get; eauto).
    repeat rewrite get_memoryIn in *.
    destruct H0.
    rewrite Elsewhere; auto.
    intros.
    destruct (weq p0 (p ^+ $(n))); subst; auto.
    eapply characterize_array8_bwd in H3; eauto.
    case_eq (smem_get (p ^+ $(n)) x2); intros; try congruence.
    destruct H; intro; eauto using no_overlap.

    apply split_comm; apply split_a_semp_a.

    eauto.
    eauto.
    reflexivity.
    auto.
  Qed.

  Ltac eqer := repeat (match goal with
                         | [ H : _ = _ |- _ ] => rewrite H in *
                         | [ H : Some _ = Some _ |- _ ] =>
                           injection H; clear H; intros
                         | [ H : Logic.ex _ |- _ ] => destruct H; try clear H
                         | [ H : _ /\ _ |- _ ] => destruct H; try clear H
                       end; subst).

  Lemma onlyChange_refl : forall p len m,
    onlyChange p len m m.
    constructor; intuition.
  Qed.

  Hint Immediate onlyChange_refl.

  Ltac prove_ReadWord :=
    eapply prove_ReadWord; hnf; intros; cbv beta in *;
      try rewrite evalInstrs_slot in *;
        match goal with
          | [ st : (W * state)%type |- _ ] => destruct st; simpl in *
          | [ st : state' |- _ ] => destruct st; simpl in *
        end;
        generalize dependent (specs m stn); intros;
          repeat match goal with
                   | [ H : interp _ _ |- _ ] => generalize dependent H
                   | [ H : context[evalInstrs] |- _ ] => generalize dependent H
                 end; clear; intros; evaluate auto_ext; auto.

  Lemma progress : forall st, goodState st
    -> exists st', sys_step stn prog st st'.
    unfold goodState; post;
      match goal with
        | [ x : label |- _ ] => destruct x
      end.

    match goal with
      | [ H : _ |- _ ] => specialize (impSys' _ _ H); intro Hi; hnf in Hi;
        unfold labelSys' in Hi; simpl in Hi; intuition subst;
          match goal with
            | [ H : (_, _) = (_, _) |- _ ] =>
              injection H; clear H; intros; subst
          end; eauto; post
    end;
    match goal with
      | [ H : interp ?specs (![locals ?a ?b ?c ?d * ?Q * ?R] ?X) |- _ ] =>
        let H' := fresh in
          assert (H' : interp specs (![locals a b c d * (Q * R)] X))
            by (generalize H; clear; intros; step auto_ext);
            clear H; rename H' into H;
              specialize (locals_mapped _ _ _ _ _ _ _ _ H);
                intro Hm; simpl in Hm
    end;
    try match goal with
          | [ H : interp ?specs (![?P * (?p =?>8 ?sz * ?Q)] ?X) |- _ ] =>
            let H' := fresh in
              assert (H' : interp specs (![p =?>8 sz * (P * Q)] X))
                by (generalize H; clear; intros; step auto_ext);
                clear H; rename H' into H;
                  specialize (bytes_mapped _ _ _ _ _ _ H);
                    intro Hb; simpl in Hb
        end;
    match goal with
      | [ H : specs _ _ _ = Some _ |- _ ] =>
        apply specs_hit in H; post; eauto
    end;
    try match goal with
          | [ st : state' |- Logic.ex _ ] =>
            solve [ exists (st#Rp, snd st); eauto
              | exists (st#Rp, snd st);
                match goal with
                  | [ _ : context["read"] |- _ ] => eapply Read
                  | _ => eapply Write
                end; eauto;
                match goal with
                  | [ H : interp _ _ |- ReadWord ?stn (Mem (snd ?st)) _ = Some _ ] =>
                    generalize H; clear; intros; prove_ReadWord
                end ]
        end.

    match goal with
      | [ H : _, H' : interp _ _ |- _ ] =>
        specialize (BlocksOk ok H); intro Hb; hnf in Hb;
          apply Hb in H'; [ | eapply specsOk; eauto ];
            clear Hb; post;
              specialize (agree _ _ _ H); destruct agree as [ ? [ ] ]
    end;
    eqer;
    match goal with
      | [ H : specs _ _ _ = Some _ |- _ ] =>
        apply specs_hit in H; post; eauto
    end;
    descend; apply Normal; unfold step;
      match goal with
        | [ H : _ = _ |- _ ] => rewrite H; eauto
      end.
  Qed.

  Lemma goOnIn : forall P Q R,
    Q * (P * R) ===> P * Q * R.
    clear; sepLemma.
  Qed.

  Lemma preservation : forall st, goodState st
    -> forall st', sys_step stn prog st st'
      -> goodState st'.
    unfold goodState; destruct 2; post;
      try match goal with
            | [ x : label, H : _ |- _ ] =>
              solve [ destruct x; specialize (impSys' _ _ H);
                intro Hi; hnf in Hi; unfold labelSys' in Hi; simpl in Hi;
                  intuition subst;
                    match goal with
                      | [ H : _ |- _ ] => apply omitImp in H;
                        match goal with
                          | [ H' : prog _ = None |- _ ] =>
                            unfold step in *; rewrite H' in *; discriminate
                        end
                    end ]

            | [ H : LabelMap.MapsTo _ _ (Blocks _), H' : interp _ _ |- _ ] =>
              solve [ specialize (BlocksOk ok H); intro Hb; hnf in Hb;
                apply Hb in H'; [ | eapply specsOk; eauto ];
                  clear Hb; post;
                    specialize (agree _ _ _ H); destruct agree as [ ? [ ] ];
                      unfold step in *; eqer;
                        apply specs_hit in H4; destruct H4; intuition idtac;
                          try match goal with
                                | [ H : Logic.ex _ |- _ ] => destruct H
                              end; eauto 10 ]

            | [ H1 : _, H2 : _ |- _ ] =>
              solve [ apply (inj _ _ _ H1) in H2; subst;
                specialize (omitImp _ _ H1);
                  match goal with
                    | [ H : _ |- _ ] => apply agree in H; post; congruence
                  end ]
          end;
      match goal with
        | [ x : label, H5 : LabelMap.MapsTo _ _ (Imports _) |- _ ] =>
          destruct x; specialize (impSys' _ _ H5);
            intro Hi; hnf in Hi; unfold labelSys' in Hi; simpl in Hi;
              intuition subst;
                match goal with
                  | [ H : (_, _) = (_, _) |- _ ] =>
                    injection H; clear H; intros; subst
                end; eauto; post;
                try match goal with
                      | [ H1 : _, H2 : _ |- _ ] =>
                        solve [ apply (inj _ _ _ H1) in H2;
                          cbv beta in H2; congruence ]
                    end; post;
                match goal with
                  | [ H : _ = _ |- _ ] => apply specs_hit in H; destruct H; intuition idtac
                end;
                match goal with
                  | [ st' : state |- _ ] => destruct st'; simpl in *; subst
                end; descend; eauto;
                match goal with
                  | [ H : forall x : ST.settings * state, _ |- _ ] =>
                    apply (Imply_sound (H _)); propxFo; descend;
                      try (apply ILTacCommon.ignore_regs; eassumption)
                end
      end;
      match goal with
        | [ H : interp (specs _ ?stn) (![?P] (_, snd ?st))%PropX |- _ ] =>
          match P with
            | context[locals _ ?V _ _] =>
              eapply ILTacCommon.interp_interp_himp in H; [ | apply comeOnOut ];
                eapply ILTacCommon.interp_interp_himp; [ | apply goOnIn ];
                  eapply tickle_bytes; eauto;
                    assert (ReadWord stn (IL.Mem (snd st)) (st#Sp ^+ $8)
                      = Some (sel V "buffer")) by prove_ReadWord;
                    assert (ReadWord stn (IL.Mem (snd st)) (st#Sp ^+ $12)
                      = Some (sel V "size")) by prove_ReadWord;
                    cbv beta in *; simpl; congruence
          end
      end.
  Qed.

  Lemma safety' : forall st, goodState st
    -> forall st', sys_reachable stn prog st st'
      -> goodState st'.
    induction 2; simpl; eauto using preservation.
  Qed.

  Theorem safety : forall st mn g pre, LabelMap.MapsTo (mn, Global g) pre (Exports m)
    -> Labels stn (mn, Global g) = Some (fst st)
    -> interp (specs0 m stn) (pre (stn, snd st))
    -> sys_safe stn prog st.
    unfold sys_safe; intros.
    eapply safety' in H2.
    auto using progress.
    hnf; descend; eauto.
    apply (ExportsSound ok) in H; eauto.
  Qed.
End OpSem.


From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq path.
From Coq Require Import Eqdep Relation_Operators.
From pcm Require Import axioms pred prelude ordtype finmap pcm unionmap heap.
From DiSeL Require Import Freshness State EqTypeX Protocols.
From DiSeL Require Import Worlds NetworkSem Rely.
From Coq Require FunctionalExtensionality.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Module ProtocolWithInvariant.
Section ProtocolWithInvariant.

Variable p : protocol.

(* Decompose the initial protocol *)
Notation l := (plab p).
Notation coh := (coh p).

(* User-provided (supposedly inductive) invariant *)
Variable I : dstatelet -> pred nid -> Prop.
(* "Initial" state *)
Variable d0 : dstatelet.

Definition W := mkWorld p.

Notation toSt d := (l \\-> d).

(* TODO: prove relation between stability and reachability *)

(* New coherence predicate: includes only reachable states *)
Definition cohI :=
  [Pred d | coh d /\ I d (nodes p d)].

(* The usual coherence properties all hold *)
Lemma cohIVd d : cohI d -> valid (dstate d).
Proof. by case=>/cohVl. Qed.

Lemma cohIVs d : cohI d -> valid (dsoup d).
Proof. by case=>/cohVs. Qed.

Lemma cohIDom d : cohI d -> dom (dstate d) =i nodes p d.
Proof. by case=>/cohDom. Qed.

(* Define it as a coherence *)
Definition CohI := CohPred (CohPredMixin cohIVd cohIVs cohIDom).

(* Some helper lemmas *)
Lemma st_helper d : (getStatelet (toSt d) l) = d.
Proof. by rewrite /getStatelet findPt. Qed.

Lemma cohSt d : coh d -> Coh W (toSt d).
Proof.
move=>C; split.
- by apply/andP; rewrite valid_unit; split=>//; apply: validPt.
- by apply: validPt.
- by move=>z lc ls st; rewrite dom0.
- by move=>z; rewrite !domPt inE.
move=>k; case B: (k \in dom (toSt d)); last first.
- rewrite /getProtocol /getStatelet.
  case: (dom_find k (toSt d))=>[->|v /find_some]; last by rewrite B.
  rewrite domPt inE/= in B.
  by case: (dom_find k (toSt p))=>[->|? /find_some]//; rewrite domPt inE/= B.
rewrite domPt inE/= in B; move/eqP: B=>B; subst k.
by rewrite /getProtocol /getStatelet !findPt.
Qed.

Section SendInvWrapper.

Variable st : send_trans coh.

Definition send_safeI this to d m :=
  send_safe st this to d m /\ I d (nodes p d).

Lemma s_safe_cohI this to d m : send_safeI this to d m -> CohI d.
Proof. by case=>/s_safe_coh=>[H1]H2. Qed.

Lemma s_safe_inI this to d m : send_safeI this to d m ->
                               this \in nodes p d /\ to \in nodes p d.
Proof. by case=>/s_safe_in. Qed.

Definition send_stepI: send_step_t (send_safeI) :=
  fun this to d msg S => (@send_step _ _ st this to d msg (proj1 S)).

Lemma s_safe_defI this to d msg :
  send_safeI this to d msg <->
  exists b pf, @send_stepI this to d msg pf = Some b.
Proof.
move: (s_safe_def st this to d msg)=>H; split.
- move=>S; case: (S)=>/H[b][pf]E H1; exists b.
  exists (conj pf H1).
  by rewrite /send_stepI (pf_irr (proj1 (conj pf H1)) pf).
by case=>b[pf]E.
Qed.

(* Inducitve step - prove that the invariant indeed holds *)
Definition S_inv := forall this to d msg (S : send_safe st this to d msg) b,
    I d (nodes p d) -> Some b = send_step S ->
    let: f' := upd this b (dstate d) in
    let: s' := (post_msg (dsoup d) (Msg (TMsg (t_snd st) msg) this to true)).1 in
    let: d' := DStatelet f' s' in
    (forall z, z == this = false -> getLocal z d' = getLocal z d) ->
    I d' (nodes p d').

Hypothesis HIstep : S_inv.

Lemma s_step_cohI : s_step_coh_t CohI (t_snd st) send_stepI.
Proof.
have E1: (getProtocol W l) = p by rewrite /getProtocol/W/=findPt.
move/s_step_coh: (st)=>H.
move=>this to d msg [S]H1 b.
rewrite /send_stepI (pf_irr (proj1 (conj S H1)) S)=>E.
split=>//= ; first by apply: (H this to d msg S b E).
apply: (HIstep H1 E _)=>//.
by move=>z N; rewrite /getLocal/= findU N.
Qed.

(* Assemble a new send-transition for the rich coherence *)
Definition snd_transI := SendTrans s_safe_cohI s_safe_inI s_safe_defI s_step_cohI.

End SendInvWrapper.

Section ReceiveInvWrapper.

Variable rt : receive_trans coh.

Definition receive_stepI: receive_step_t CohI :=
  fun this from m d C pf => receive_step rt from m (proj1 C) pf.

Definition R_inv := forall d from this i (C : coh d) m
                           (pf: this \in nodes p d),
    I d (nodes p d) ->
    find i (dsoup d) = Some (Msg m from this true) ->
    this \in dom (dstate d) ->
    msg_wf rt C this from m -> tag m = t_rcv rt ->
    let: loc' := receive_step rt from m C pf in
    let: s'' := consume_msg (dsoup d) i in
    let: f' := upd this loc' (dstate d) in
    let: d' := (DStatelet f' s'') in
    (forall z, z == this = false -> getLocal z d' = getLocal z d) ->
    I d' (nodes p d').

Hypothesis HIstep : R_inv.

Notation msg_wfI := (fun d (C : CohI d) => msg_wf rt (proj1 C)).

Lemma r_step_cohI :
  r_step_coh_t msg_wfI (t_rcv rt) receive_stepI.
Proof.
have E1: (getProtocol W l) = p by rewrite /getProtocol/W/=findPt.
move=>d from this i C F m D N Wf T.
rewrite /receive_stepI/=.
set d' := {| dstate := upd this (receive_step rt from m (proj1 C) F) (dstate d);
             dsoup := consume_msg (dsoup d) i |}.
split; first by apply: (r_step_coh F D N Wf T).
- apply: (HIstep (proj2 C) N D Wf T)=>//z N'.
  by rewrite /getLocal findU N'.
Qed.

Definition rcv_transI := @ReceiveTrans _ CohI _ msg_wfI _ r_step_cohI.

End ReceiveInvWrapper.

(* The client has to provide instances of the following
   two structures along with the proofs of Hs and Hr. *)

Structure SendInv := SI {
  st : send_trans coh;
  st_inv : S_inv st;
}.

Structure ReceiveInv := RI {
  rt : receive_trans coh;
  rt_inv : R_inv rt;
}.

Structure InductiveInv := II {
  sts : seq SendInv;
  rts : seq ReceiveInv;
  _ : map st sts = snd_trans p;
  _ : map rt rts = rcv_trans p
}.

(* Obtain new send/receive transitions *)
Definition stsI sts := map (fun stt =>
                          @snd_transI (st stt) (@st_inv stt)) sts.
Definition rtsI rts := map (fun rtt =>
                          @rcv_transI (rt rtt) (@rt_inv rtt)) rts.

Import FunctionalExtensionality.

Variable ii : InductiveInv.

Lemma us : uniq (map (@t_snd _ _) (stsI (sts ii))).
Proof.
case: ii=>sts rts Hs Hr; rewrite /stsI -seq.map_comp/=.
suff E: (t_snd (coh:=CohI) \o
               (fun stt : SendInv => snd_transI (st_inv (s:=stt))))
        = fun stt => t_snd (st stt).
by rewrite E seq.map_comp; rewrite Hs; apply: snd_uniq.
(* TODO: can we do without this? *)
by apply: functional_extensionality=>z.
Qed.

Lemma ur : uniq (map (@t_rcv _ _) (rtsI (rts ii))).
Proof.
case: ii=>sts rts Hs Hr; rewrite /stsI -seq.map_comp/=.
suff E: (t_rcv (coh:=CohI) \o
               (fun rtt : ReceiveInv => rcv_transI (rt_inv (r:=rtt))))
        = fun rtt => t_rcv (rt rtt).
by rewrite E seq.map_comp; rewrite Hr; apply: rcv_uniq.
(* TODO: can we do without this? *)
by apply: functional_extensionality=>z.
Qed.

Definition ProtocolWithIndInv := @Protocol _ l _ _ _ us ur.

Lemma stIn (s : SendInv) :
  s \In (sts ii) ->
  (snd_transI (@st_inv s)) \In (snd_trans ProtocolWithIndInv).
Proof. by move=>H; rewrite /stsI/=; apply/Mem_map. Qed.

Lemma rtIn (r : ReceiveInv) :
  r \In (rts ii) ->
  (rcv_transI (@rt_inv r)) \In (rcv_trans ProtocolWithIndInv).
Proof. by move=>H; rewrite /rtsI/=; apply/Mem_map. Qed.

Lemma getInvSendTrans st z to msg s1 h :
  st \In (snd_trans ProtocolWithIndInv) ->
  forall (S : send_safe st z to (getStatelet s1 (plab p)) msg),
  Some h = send_step S ->
  exists st', [/\ st' \In get_st (mkWorld p) (plab p),
     t_snd st' = t_snd st,
     all_hooks_fire (mkWorld p) (plab p) (t_snd st') s1 z msg to &
     exists S': (send_safe st' z to (getStatelet s1 (plab p)) msg),
       Some h = send_step S'].
Proof.
simpl; case: ii=>sts rts HS HR/=; rewrite /stsI.
case/Mem_map_inv; case=>st' stI/= [->]H1; case=>S Is E.
rewrite /get_st/InMem!prEq; exists st'. split=>//.
- by rewrite -HS/=; apply: (Mem_map ProtocolWithInvariant.st H1).
rewrite/send_step/=/Transitions.send_step/=/send_stepI in E.
- move=>??? F.
  apply sym_eq in F.
  move: F.
  by move/find_some; rewrite dom0.
by exists (proj1 (conj S Is)).
Qed.

End ProtocolWithInvariant.

Section InductiveInvConj.

Variable p : protocol.

Definition s_inv_conj (I1 I2 : dstatelet -> pred nid -> Prop)
           (st : send_trans (coh p)) :=
  S_inv (fun d n => I1 d n /\ I2 d n) st.

Lemma s_inv_conjC I1 I2 st :
  s_inv_conj I1 I2 st <-> s_inv_conj I2 I1 st.
Proof.
by split; move=>H this to d msg S b /and_comm G E N; apply/and_comm; apply: H.
Qed.

Lemma s_inv_conjA I1 I2 I3 st :
  s_inv_conj I1 (fun d n => I2 d n /\ I3 d n) st <->
  s_inv_conj (fun d n => I1 d n /\ I2 d n) I3 st.
Proof.
by split=>H this to d msg S b /and_assoc G E N; apply/and_assoc; apply: H.
Qed.

Definition r_inv_conj (I1 I2 : dstatelet -> pred nid -> Prop)
           (rt : receive_trans (coh p)) :=
  R_inv (fun d n => I1 d n /\ I2 d n) rt.

Lemma r_inv_conjC I1 I2 rt :
  r_inv_conj I1 I2 rt <-> r_inv_conj I2 I1 rt.
Proof.
by split=>H d from this i C m pf/and_comm G E D W T N; apply/and_comm; apply: H.
Qed.

Lemma r_inv_conjA I1 I2 I3 rt :
  r_inv_conj I1 (fun d n => I2 d n /\ I3 d n) rt <->
  r_inv_conj (fun d n => I1 d n /\ I2 d n) I3 rt.
Proof.
by split=>H d from this i C m pf/and_assoc G E D W T N; apply/and_assoc; apply: H.
Qed.

(* Definition ii_conj (I1 I2 : dstatelet -> pred nid -> Prop) *)
(*            (ii1 : InductiveInv p I1) *)
(*            (ii2 : InductiveInv p I2) : *)
(*   InductiveInv p (fun d n => I1 d n /\ I2 d n). *)
(* Proof. *)
(* case: ii1 ii2=>sts1 rts1 Es1 Er1 [sts2] rts2 Es2 Er2. *)
(* Qed. *)

End InductiveInvConj.

End ProtocolWithInvariant.

Module PWIExports.
Section PWIExports.

Import ProtocolWithInvariant.

Definition st_helper := st_helper.
Definition cohSt := cohSt.

Definition S_inv := ProtocolWithInvariant.S_inv.
Definition R_inv := ProtocolWithInvariant.R_inv.

Definition SendInv := SendInv.
Definition SI := SI.
Definition ReceiveInv := ReceiveInv.
Definition RI := RI.

Definition InductiveInv := InductiveInv.

Lemma with_inv_coh pr I (ii : InductiveInv pr I) s:
  s \In Coh (mkWorld (ProtocolWithIndInv ii)) ->
  s \In Coh (mkWorld pr).
Proof.
case=>G1 G2 Gh G3 G4; split=>//.
- by apply/andP; rewrite valid_unit; split=>//; rewrite !validPt in G1 *.
- by move=>???? ;rewrite dom0.
- by move=>z; move: (G3 z); rewrite !domPt !inE.
move=>l; move: (G4 l).
case X: (l == plab pr); first by move/eqP:X=>X; subst l; rewrite !prEq; case.
rewrite /getProtocol/mkWorld/=.
suff [X1 X2]: l \notin dom (plab pr \\-> ProtocolWithIndInv ii) /\
              l \notin dom (plab pr \\-> pr).
- by case: dom_find X1 X2=>//=->_; case: dom_find=>//=->.
rewrite !domPt !inE/=; suff: plab pr != l by [].
by apply/negbT; apply/negP=>/eqP Z; subst l; rewrite eqxx in X.
Qed.

Lemma with_inv_nodes pr I (ii : InductiveInv pr I) l :
  nodes (getProtocol (mkWorld (ProtocolWithIndInv ii)) l) =
  nodes (getProtocol (mkWorld pr) l).
Proof.
rewrite /getProtocol/mkWorld/=.
case X: (l == plab pr);
  first by move/eqP:X=>X; subst l; rewrite !findPt.
rewrite /getProtocol/mkWorld/=.
suff [X1 X2]: l \notin dom (plab pr \\-> ProtocolWithIndInv ii) /\
              l \notin dom (plab pr \\-> pr).
by case: dom_find X1 X2=>//=->_; case: dom_find=>//=->.
rewrite !domPt !inE/=; suff: plab pr != l by [].
by apply/negbT; apply/negP=>/eqP Z; subst l; rewrite eqxx in X.
Qed.

Lemma with_inv_labE pr I (ii : InductiveInv pr I):
  plab (ProtocolWithIndInv ii) = plab pr.
Proof. by []. Qed.

Lemma with_inv_step pr I (ii : InductiveInv pr I) z s1 s2:
  s1 \In Coh (mkWorld (ProtocolWithIndInv ii)) ->
  network_step (mkWorld pr) z s1 s2 ->
  network_step (mkWorld (ProtocolWithIndInv ii)) z s1 s2.
Proof.
move=>C'; move: (with_inv_coh C')=>C.
case; first by case=>_<-; apply: Idle.

(*** Send-transition of the host protocol ***)
move=>l st Hs to msg h H1 H2 _ S A E ->/=.
have Y : l = plab pr
  by rewrite -(cohD C) domPt inE/= in H2; move/eqP:H2.
subst l; move: st Hs H1 S E A; rewrite /get_st/InMem!prEq/==>st Hs H1 S E A.
suff X: exists st',
    [/\ st' \In get_st (mkWorld (ProtocolWithIndInv ii)) (plab pr),
     t_snd st' = t_snd st,
     all_hooks_fire (mkWorld (ProtocolWithIndInv ii)) (plab pr) (t_snd st') s1 z msg to &
     exists S': (send_safe st' z to (getStatelet s1 (plab pr)) msg),
                Some h = send_step S'].
case:X=>st'[Hs']Et A'[S']E'; rewrite -Et.
move: (with_inv_nodes ii (plab pr)); rewrite !prEq=>P.
by rewrite -P in H1; apply: (SendMsg (to:=to)(this:=z)(b:=h)(msg:=msg) Hs').

(* Finding the corresponding send-transition of rich protocol *)
rewrite -(with_inv_labE ii)/get_st/InMem!prEq.
case: ii (@stIn _ _ ii) C' =>sts rts HS HR/= Hi C'.
rewrite -HS in Hs; move/Mem_map_inv: Hs=>[[st' stI]]/=[Es]Si; subst st'.
have G: I (getStatelet s1 (plab pr)) (nodes pr (getStatelet s1 (plab pr))).
+ by case: C'=>_ _ _ _/(_ (plab pr)); rewrite prEq; case.
move:(Hi _ Si)=>/={Hi Si}Hi; exists (@snd_transI pr I st stI); split=>//=.
rewrite /send_safeI /send_stepI/=.
by exists (conj S G); rewrite (pf_irr (proj1 (conj S G)) S).

(*** Receive-transition of the host protocol ***)
move=>l rt  Hr i from H1 H2 C1 msg E[F]Hw/=.
have Y : l = plab pr by rewrite -(cohD C) domPt inE/= in H2; move/eqP:H2.
subst l; move: rt Hr H1 E (coh_s _ C1) Hw.
rewrite /get_rt/InMem/=!prEq=>rt Hr H1 E C1' Hw .
have Hi: (coh (getProtocol (mkWorld (ProtocolWithIndInv ii)) (plab pr)))
           (getStatelet s1 (plab pr)) by case:C'=>_ _ _/(_ (plab pr)).
have Hz : z \in nodes
          (getProtocol (mkWorld (ProtocolWithIndInv ii)) (plab pr))
          (getStatelet s1 (plab pr)) by rewrite (with_inv_nodes ii (plab pr)) prEq.
suff X: exists rt',
     [/\ rt' \In get_rt (mkWorld (ProtocolWithIndInv ii)) (plab pr),
      tag msg = t_rcv rt', msg_wf rt' Hi z from msg &
      receive_step rt from msg C1' H1 = receive_step rt' from msg Hi Hz].
case:X=>rt'[Hr']E' Hw' Gr G.
have pf: (z \in nodes (getProtocol (mkWorld (ProtocolWithIndInv ii)) (plab pr))
                  (getStatelet s1 (plab pr))) by rewrite prEq.
move: (@ReceiveMsg _ z s1 s2 (plab pr) rt' Hr' i from pf)=>/=.
rewrite -(cohD C) /= domPt inE eqxx/=; move/(_ is_true_true C' msg E')=>X.
subst s2; apply X; split=>//; clear X.
- by rewrite (pf_irr (coh_s (plab pr) C') Hi).
congr (upd _ _); congr {| dstate := _ ; dsoup := _ |}; congr (upd _ _).
rewrite Gr; clear E E' Hw Hw' Hr Hr' Gr rt F H2 H1 C1 C.
rewrite (pf_irr pf Hz).
by rewrite (pf_irr Hi (coh_s (plab pr) C')).

(* Finding the corresponding receive-transition of rich protocol *)
rewrite /get_rt/InMem/=; move: C1' H1 Hi Hz Hw; rewrite !prEq=>C1' H1 Hi Hz Hw.
case: ii (@rtIn _ _ ii) C' Hi Hz=>/=sts rts HS HR/= Hi C'.
rewrite -HR in Hr; move/Mem_map_inv: Hr=>[[rt' rtI]]/=[Er]Ri; subst rt'.
case=>C1'' Inv Hz. exists (@rcv_transI pr I rt rtI); split=>//.
- by move: (@Hi _ Ri).
rewrite /receive_step/=/receive_stepI/=/receive_step/=.
- by rewrite -(pf_irr C1' (proj1 (conj C1'' Inv))).
by rewrite ?(pf_irr C1' (proj1 (conj C1'' Inv)))
           ?(pf_irr H1 Hz).
Qed.

Lemma with_inv_step' pr I (ii : InductiveInv pr I) z s1 s2:
  network_step (mkWorld (ProtocolWithIndInv ii)) z s1 s2 ->
  network_step (mkWorld pr) z s1 s2.
Proof.
case.
- by case=>C'<-; apply: Idle; split=>//; apply: with_inv_coh C'.
(* Emulating send-transition *)
move=>l st Hs to msg h H1 H2 C' S A E->{s2}.
have Y : l = plab pr
  by rewrite -(cohD C') domPt inE/= in H2; move/eqP:H2.
subst l; move: st Hs H1 S E A; rewrite /get_st/InMem!prEq/==>st Hs H1 S E A.
suff X: exists st',
    [/\ st' \In get_st (mkWorld pr) (plab pr),
     t_snd st' = t_snd st,
     all_hooks_fire (mkWorld (ProtocolWithIndInv ii)) (plab pr) (t_snd st') s1 z msg to &
     exists S': (send_safe st' z to (getStatelet s1 (plab pr)) msg),
                Some h = send_step S'].
case:X=>st'[Hs']Et A'[S']E'; rewrite -Et.
apply: (SendMsg (to:=to)(this:=z)(b:=h)(msg:=msg) Hs')=>//;
  [by rewrite prEq| by apply: (with_inv_coh C')].
by apply: (getInvSendTrans (ii := ii)).

(* Emulating a receive-transition *)
move=>l rt  Hr i from H1 H2 C1 msg E[F]Hw/=.
have Y : l = plab pr by rewrite -(cohD C1) domPt inE/= in H2; move/eqP:H2.
subst l; move: rt Hr H1 E (coh_s _ C1) Hw.
rewrite /get_rt/InMem/=!prEq=>rt Hr H1 E C1' Hw.
have Hi: (coh (getProtocol (mkWorld pr) (plab pr)))
           (getStatelet s1 (plab pr)) by case:(C1'); rewrite prEq.
have Hz : z \in nodes (getProtocol (mkWorld pr) (plab pr))
                      (getStatelet s1 (plab pr))
  by rewrite -(with_inv_nodes ii (plab pr)) prEq.
suff X: exists rt',
     [/\ rt' \In get_rt (mkWorld pr) (plab pr),
      tag msg = t_rcv rt', msg_wf rt' Hi z from msg &
      receive_step rt from msg C1' H1 = receive_step rt' from msg Hi Hz].
case:X=>rt'[Hr']E' Hw' Gr G.
have pf: (z \in nodes (getProtocol (mkWorld pr) (plab pr))
                  (getStatelet s1 (plab pr))) by rewrite prEq.
move: (@ReceiveMsg _ z s1 s2 (plab pr) rt' Hr' i from pf)=>/=.
rewrite -(cohD C1) domPt inE eqxx/=.
move/(_ is_true_true (with_inv_coh C1) msg E')=>X.
subst s2; apply X; split=>//; clear X.
- by rewrite (pf_irr (coh_s (plab pr) (with_inv_coh C1)) Hi).
congr (upd _ _); congr {| dstate := _ ; dsoup := _ |}; congr (upd _ _).
rewrite Gr; clear E E' Hw Hw' Hr Hr' Gr rt F H2 H1.
rewrite (pf_irr pf Hz).
by rewrite (pf_irr Hi (coh_s (plab pr) (with_inv_coh C1))).
(* Identifying the appropriate receive transition *)
case: ii C1 H2 rt Hr E H1 C1' Hw=>sts rts HS HR/=C1 H2 rt Hr E H1 C1' Hw.
move: Hr; rewrite /rtsI.
case/Mem_map_inv; case=>rt' rtI/= [Z] H1'; subst rt.
rewrite /get_rt/InMem; move: C1' H1 Hi Hz Hw; rewrite !prEq=>C1' H1 Hi Hz Hw.
exists rt'; split=>//; last first.
- rewrite {1}/receive_step /rcv_transI /receive_stepI/=.
  rewrite (pf_irr H1 Hz).
  by rewrite (pf_irr (proj1 C1') Hi).
- by rewrite -(pf_irr (proj1 C1') Hi).
by rewrite -HR; apply: (Mem_map (@ProtocolWithInvariant.rt pr I) H1').
Qed.

Lemma with_inv_rely' pr I (ii : InductiveInv pr I) z s1 s2:
  network_rely (mkWorld (ProtocolWithIndInv ii)) z s1 s2 ->
  network_rely (mkWorld pr) z s1 s2.
Proof.
case=>n; elim: n s1=>[|n Hi] s1; first by move=>[<-]/with_inv_coh=>C; exists 0.
case=>z'[s3][N]H/Hi; move/with_inv_step':H=>S; case=>n' R.
by exists n'.+1, z', s3.
Qed.

(* The following definition requires the proofs, for each transitions
   of p that it satisfies the corresponding two-state invariants with
   respect to the supposedly inductive I. *)

Definition ProtocolWithIndInv := ProtocolWithIndInv.

End PWIExports.
End PWIExports.

Export PWIExports.


(* This file is an automatic translation, the licence of the source can be found here: *)
(* https://github.com/herd/herdtools7/blob/master/LICENSE.txt *)
(* Translation of model AllFences *)
From Coq Require Import Relations Ensembles String.
From RelationAlgebra Require Import lattice prop monoid rel kat.
From Catincoq.lib Require Import Cat proprel.
Section Model.
Variable c : candidate.
Definition events := events c.
Definition R := R c.
Definition W := W c.
Definition IW := IW c.
Definition FW := FW c.
Definition B := B c.
Definition RMW := RMW c.
Definition F := F c.
Definition rf := rf c.
Definition po := po c.
Definition int := int c.
Definition ext := ext c.
Definition loc := loc c.
Definition addr := addr c.
Definition data := data c.
Definition ctrl := ctrl c.
Definition amo := amo c.
Definition rmw := rmw c.
Definition unknown_set := unknown_set c.
Definition unknown_relation := unknown_relation c.
Definition M := R ⊔ W.
Definition emptyset : set events := empty.
Definition classes_loc : set events -> Ensemble (Ensemble events) := partition loc.
Definition tag2events := unknown_relation "tag2events".
Definition emptyset_0 : set events := domain 0.
Definition partition := classes_loc.
Definition tag2instrs := tag2events.
Definition po_loc := po ⊓ loc.
Definition rfe := rf ⊓ ext.
Definition rfi := rf ⊓ int.
Definition co0 := loc ⊓ ([IW] ⋅ top ⋅ [(W ⊓ !IW)] ⊔ [(W ⊓ !FW)] ⋅ top ⋅ [FW]).
Definition toid (s : set events) : relation events := [s].
Definition fencerel (B : set events) := (po ⊓ [top] ⋅ top ⋅ [B]) ⋅ po.
Definition ctrlcfence (CFENCE : set events) := (ctrl ⊓ [top] ⋅ top ⋅ [CFENCE]) ⋅ po.
Definition imply (A : relation events) (B : relation events) := !A ⊔ B.
Definition nodetour (R1 : relation events) (R2 : relation events) (R3 : relation events) := R1 ⊓ !(R2 ⋅ R3).
Definition singlestep (R : relation events) := nodetour R R R.
(* Definition of map already included in the prelude *)
Definition LKW := (*failed: try LKW with emptyset_0*) emptyset_0.
Definition mfence : relation events := (*failed: try fencerel MFENCE with 0*) 0.
Definition lfence : relation events := (*failed: try fencerel LFENCE with 0*) 0.
Definition sfence : relation events := (*failed: try fencerel SFENCE with 0*) 0.
Definition dmb_st : relation events := (*failed: try fencerel DMB.ST with 0*) 0.
Definition dsb_st : relation events := (*failed: try fencerel DSB.ST with 0*) 0.
Definition dmb : relation events := (*failed: try fencerel DMB with 0*) 0.
Definition dsb : relation events := (*failed: try fencerel DSB with 0*) 0.
Definition isb : relation events := (*failed: try fencerel ISB with 0*) 0.
Definition ctrlisb : relation events := (*failed: try ctrlcfence ISB with 0*) 0.
Definition sync : relation events := (*failed: try fencerel SYNC with 0*) 0.
Definition lwsync : relation events := (*failed: try fencerel LWSYNC with 0*) 0.
Definition eieio : relation events := (*failed: try fencerel EIEIO with 0*) 0.
Definition isync : relation events := (*failed: try fencerel ISYNC with 0*) 0.
Definition ctrlisync : relation events := (*failed: try ctrlcfence ISYNC with 0*) 0.
Definition DMB_ISH := (*failed: try DMB.ISH with emptyset_0*) emptyset_0.
Definition DMB_ISHLD := (*failed: try DMB.ISHLD with emptyset_0*) emptyset_0.
Definition DMB_ISHST := (*failed: try DMB.ISHST with emptyset_0*) emptyset_0.
Definition DSB_ISH := (*failed: try DSB.ISH with emptyset_0*) emptyset_0.
Definition DSB_ISHLD := (*failed: try DSB.ISHLD with emptyset_0*) emptyset_0.
Definition DSB_ISHST := (*failed: try DSB.ISHST with emptyset_0*) emptyset_0.
Definition DMB_SY := (*failed: try DMB.SY with emptyset_0*) emptyset_0.
Definition DMB_ST := (*failed: try DMB.ST with emptyset_0*) emptyset_0.
Definition DMB_LD := (*failed: try DMB.LD with emptyset_0*) emptyset_0.
Definition DSB_SY := (*failed: try DSB.SY with emptyset_0*) emptyset_0.
Definition DSB_ST := (*failed: try DSB.ST with emptyset_0*) emptyset_0.
Definition DSB_LD := (*failed: try DSB.LD with emptyset_0*) emptyset_0.
Definition DMB_OSH := (*failed: try DMB.OSH with emptyset_0*) emptyset_0.
Definition DSB_OSH := (*failed: try DSB.OSH with emptyset_0*) emptyset_0.
Definition DMB_OSHLD := (*failed: try DMB.OSHLD with emptyset_0*) emptyset_0.
Definition DSB_OSHLD := (*successful: try DSB.OSH with emptyset_0*) DSB_OSH.
Definition DMB_OSHST := (*failed: try DMB.OSHST with emptyset_0*) emptyset_0.
Definition DSB_OSHST := (*failed: try DSB.OSHST with emptyset_0*) emptyset_0.
Definition ISB := (*failed: try ISB with emptyset_0*) emptyset_0.
Definition A := (*failed: try A with emptyset_0*) emptyset_0.
Definition L := (*failed: try L with emptyset_0*) emptyset_0.
Definition Q := (*failed: try Q with emptyset_0*) emptyset_0.
Definition NoRet := (*failed: try NoRet with emptyset_0*) emptyset_0.
Definition dmb_ish := fencerel DMB_ISH.
Definition dmb_ishld := fencerel DMB_ISHLD.
Definition dmb_ishst := fencerel DMB_ISHST.
Definition dmb_fullsy := fencerel DMB_SY.
Definition dmb_fullst := fencerel DMB_ST.
Definition dmb_fullld := fencerel DMB_LD.
Definition dmb_sy := dmb_fullsy ⊔ dmb_ish.
Definition dmb_st_0 := dmb_fullst ⊔ dmb_ishst.
Definition dmb_ld := dmb_fullld ⊔ dmb_ishld.
Definition dsb_sy := fencerel DSB_SY.
Definition dsb_st_0 := fencerel DSB_ST.
Definition dsb_ld := fencerel DSB_LD.
Definition isb_0 := fencerel ISB.
Definition ctrlisb_0 := (*successful: try ctrlcfence ISB with 0*) ctrlcfence ISB.
Definition ctrlcfence_0 := ctrlisb_0 ⊔ ctrlisync.
Definition witness_conditions := True.
Definition model_conditions := True.
End Model.

Hint Unfold events R W IW FW B RMW F rf po int ext loc addr data ctrl amo rmw unknown_set unknown_relation M emptyset classes_loc tag2events emptyset_0 partition tag2instrs po_loc rfe rfi co0 toid fencerel ctrlcfence imply nodetour singlestep LKW mfence lfence sfence dmb_st dsb_st dmb dsb isb ctrlisb sync lwsync eieio isync ctrlisync DMB_ISH DMB_ISHLD DMB_ISHST DSB_ISH DSB_ISHLD DSB_ISHST DMB_SY DMB_ST DMB_LD DSB_SY DSB_ST DSB_LD DMB_OSH DSB_OSH DMB_OSHLD DSB_OSHLD DMB_OSHST DSB_OSHST ISB A L Q NoRet dmb_ish dmb_ishld dmb_ishst dmb_fullsy dmb_fullst dmb_fullld dmb_sy dmb_st_0 dmb_ld dsb_sy dsb_st_0 dsb_ld isb_0 ctrlisb_0 ctrlcfence_0 witness_conditions model_conditions : cat.

Definition valid (c : candidate) := True.

(* End of translation of model AllFences *)


Require Import ExtLib.Structures.Monad.

Set Universe Polymorphism.
Set Printing Universes.

Class MonadState@{s d c} (T : Type@{s}) (m : Type@{d} -> Type@{c}) : Type :=
{ get : m T
; put : T -> m unit
}.

Arguments get {_ m MS} : rename.
Arguments put {_ m MS} _ : rename.

Section monadic.
  Polymorphic Universes s d c.
  Context {m : Type@{d} -> Type@{c}}.
  Context {M : Monad@{d c} m}.
  Context {T : Type@{s}}.
  Context {MS : MonadState@{s d c} T m}.

  Definition modify (f : T -> T) : m T :=
    bind get (fun x => bind (put (f x)) (fun _ => ret x)).

  Definition gets {U} (f : T -> U) : m U :=
    bind get (fun x => ret (f x)).

End monadic.

Section SubState.
  Polymorphic Universes s d c.
  Context {m : Type@{d} -> Type@{c}}.
  Context {M : Monad@{d c} m}.
  Context {T S : Type@{s}}.
  Context {MS : MonadState@{s d c} T m}.

  Definition StateProd (f : T -> S) (g : S -> T -> T)
    : MonadState S m :=
  {| get := @gets m M T MS S f
   ; put := fun x => bind get (fun s => put (g x s))
   |}.
End SubState.


(**************************************************************************)
(*                                                                        *)
(*     Sniper                                                             *)
(*     Copyright (C) 2021                                                 *)
(*                                                                        *)
(*     See file "AUTHORS" for the list of authors                         *)
(*                                                                        *)
(*   This file is distributed under the terms of the CeCILL-C licence     *)
(*                                                                        *)
(**************************************************************************)

Require Export SMTCoq.SMTCoq.

From elpi Require Import elpi.

Require Export utilities.
Require Export definitions.
Require Export higher_order.
Require Export anonymous_functions.
Require Export elimination_fixpoints.
Require Export expand.
Require Export elimination_pattern_matching.
Require Export elimination_polymorphism.
Require Export case_analysis.
Require Export case_analysis_existentials.
Require Export interpretation_algebraic_types.
Require Export instantiate.
Require Export indrel.
Require Import ZArith.
Require Import PArith.BinPos.
Require Import SMTCoq.bva.BVList.
Require Import NArith.BinNatDef.

(** Preprocessing for SMTCoq (first-order classical logic with interpreted theories) **)

(* Tuple of symbols we do not want to unfold
in the default tactic *)
Definition prod_of_symb := (impossible_term,
         Zplus,
         Zminus,
         Zmult,
         Z.eqb,
         Zlt_bool,
         Zle_bool,
         Zge_bool,
         Zgt_bool,
         Z.lt,
         Z.le,
         Z.ge,
         Z.gt,
         Pos.lt,
         Pos.le,
         Pos.ge,
         Pos.gt,
         Z.to_nat,
         Pos.mul,
         Pos.add,
         Pos.sub,
         Init.Nat.add,
         Init.Nat.mul,
         Nat.eqb,
         Nat.leb,
         Nat.ltb,
         Init.Peano.lt,
         Init.Peano.ge,
         Init.Peano.gt,
         N.add,
         N.mul,
         N.eqb,
         N.leb,
         N.ltb,
         Init.Peano.lt,
         Init.Peano.ge,
         Init.Peano.gt,
         negb,
         not,
         andb,
         orb,
         implb,
         xorb,
         Bool.eqb,
         iff,
         @BITVECTOR_LIST.bv_eq,
         @BITVECTOR_LIST.bv_and,
         @BITVECTOR_LIST.bv_or,
         @BITVECTOR_LIST.bv_xor,
         @BITVECTOR_LIST.bv_add,
         @BITVECTOR_LIST.bv_mult,
         @BITVECTOR_LIST.bv_ult,
         @BITVECTOR_LIST.bv_slt,
         @BITVECTOR_LIST.bv_concat,
         @BITVECTOR_LIST.bv_shl,
         @BITVECTOR_LIST.bv_shr,
         @FArray.select,
         @FArray.diff,
         is_true,
         @eqb_of_compdec).

Definition prod_types := (Z, bool, True, False, positive, N, and, or, nat, Init.Peano.le).

Ltac def_and_pattern_matching p1 k :=
anonymous_funs ; prenex_higher_order_with_equations ;
let p1' := eval unfold p1 in p1 in
k p1' ltac:(fun H => expand_hyp_cont H ltac:(fun H' =>
eliminate_dependent_pattern_matching H')).

Ltac def_fix_and_pattern_matching p1 k :=
anonymous_funs ; prenex_higher_order_with_equations ;
let p1' := eval unfold p1 in p1 in
k p1' ltac:(fun H => expand_hyp_cont H ltac:(fun H' =>
eliminate_fix_ho H' ltac:(fun H'' =>
try (eliminate_dependent_pattern_matching H'')))).

Ltac def_and_pattern_matching_mono p1 k :=
def_and_pattern_matching p1 k ; inst.

Ltac def_and_pattern_matching_mono_param p1 t k :=
def_and_pattern_matching p1 k ; inst t.

Ltac def_fix_and_pattern_matching_mono_param p1 t k :=
def_fix_and_pattern_matching p1 k ; inst t.

Ltac scope_param p1 p2 t :=
let p2' := eval unfold p2 in p2 in
intros ;
repeat match goal with
| H : _ |- _  => eliminate_dependent_pattern_matching H
| _ => fail
end ;
try interp_alg_types_context_goal p2' ; try (def_fix_and_pattern_matching_mono_param p1 t
ltac:(get_definitions_theories_no_generalize)) ;
get_projs_in_variables p2'.

Ltac scope_no_param p1 p2 :=
let p2' := eval unfold p2 in p2 in
intros ;
repeat match goal with
| H : _  |- _ => eliminate_dependent_pattern_matching H
| _ => fail
end ;
try interp_alg_types_context_goal p2'; try (def_fix_and_pattern_matching p1 ltac:(get_definitions_theories); intros ; inst) ;
get_projs_in_variables p2'.

Ltac snipe_param_no_check p1 p2 t :=
scope_param p1 p2 t ; verit_no_check.

Ltac snipe_no_param_no_check p1 p2 :=
scope_no_param p1 p2 ; verit_no_check.

Ltac snipe_param p1 p2 t :=
scope_param p1 p2 t ; verit.

Ltac snipe_no_param p1 p2 :=
scope_no_param p1 p2 ; verit.

Tactic Notation "elimination_polymorphism" uconstr_list_sep(l, ",") :=
  elpi elimination_polymorphism ltac_term_list:(l) ; clear_prenex_poly_hyps_in_context.

Tactic Notation "scope2_aux" constr(p1) constr(p2) uconstr_list_sep(l, ",") :=
let p2' := eval unfold p2 in p2 in
intros ;
repeat match goal with
| H : _ |- _  => eliminate_dependent_pattern_matching H
| _ => fail
end ;
try interp_alg_types_context_goal p2' ; try (def_fix_and_pattern_matching p1 ltac:(get_definitions_theories_no_generalize) ;
elpi elimination_polymorphism ltac_term_list:(l) ; clear_prenex_poly_hyps_in_context) ;
get_projs_in_variables p2'.

Tactic Notation "snipe2" uconstr_list_sep(l, ",") :=
let p2' := eval unfold prod_types in prod_types in
intros ;
repeat match goal with
| H : _ |- _  => eliminate_dependent_pattern_matching H
| _ => fail
end ;
try interp_alg_types_context_goal p2' ; try (def_fix_and_pattern_matching prod_of_symb ltac:(get_definitions_theories_no_generalize); intros ;
elpi elimination_polymorphism ltac_term_list:(l) ; clear_prenex_poly_hyps_in_context) ;
get_projs_in_variables p2' ; verit.

Tactic Notation "snipe_no_check" constr(t) := snipe_param_no_check prod_of_symb prod_types t.
Tactic Notation "snipe_no_check" := snipe_no_param_no_check prod_of_symb prod_types.

Tactic Notation "scope" constr(t) := scope_param prod_of_symb prod_types t.
Tactic Notation "scope" := scope_no_param prod_of_symb prod_types.

Tactic Notation "snipe" constr(t) := snipe_param prod_of_symb prod_types t.
Tactic Notation "snipe" := snipe_no_param prod_of_symb prod_types.

Tactic Notation "snipe_no_check_timeout" constr(t) int_or_var(n) := scope_param prod_of_symb prod_types t ; verit_no_check_timeout n.
Tactic Notation "snipe_no_check_timeout" int_or_var(n) := scope_no_param prod_of_symb prod_types ; verit_no_check_timeout n.

Tactic Notation "snipe_timeout" constr(t) int_or_var(n) := scope_param prod_of_symb prod_types t ; verit_timeout n.
Tactic Notation "snipe_timeout" int_or_var(n) := scope_no_param prod_of_symb prod_types ; verit_timeout n.

(** Preprocessing for first-order intuitionistic logic with no interpreted symbols **)

Definition tuple_def := (iff, not).

Ltac scope_param_intuitionistic t :=
intros ;
repeat match goal with
| H : _ |- _  => eliminate_dependent_pattern_matching H
| _ => fail
end ;
try interp_alg_types_context_goal impossible_term ; try (def_fix_and_pattern_matching_mono_param tuple_def t
ltac:(get_definitions_theories_no_generalize); inv_principle_all; inst) ;
get_projs_in_variables tuple_def.

Ltac scope_no_param_intuitionistic :=
intros ;
repeat match goal with
| H : _ |- _  => eliminate_dependent_pattern_matching H
| _ => fail
end ;
try interp_alg_types_context_goal impossible_term ; try (def_fix_and_pattern_matching tuple_def
ltac:(get_definitions_theories_no_generalize) ; inv_principle_all ; inst) ;
get_projs_in_variables tuple_def.