From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Loc.
From PromisingLib Require Import Event.

Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.

Set Implicit Arguments.

Module MemoryReorder.
  Lemma add_add
        mem0 loc1 from1 to1 msg1
        mem1 loc2 from2 to2 msg2
        mem2
        (ADD1: Memory.add mem0 loc1 from1 to1 msg1 mem1)
        (ADD2: Memory.add mem1 loc2 from2 to2 msg2 mem2):
    exists mem1',
      <<ADD1: Memory.add mem0 loc2 from2 to2 msg2 mem1'>> /\
      <<ADD2: Memory.add mem1' loc1 from1 to1 msg1 mem2>> /\
      <<LOCTS: (loc1, to1) <> (loc2, to2)>>.
  Proof.
    exploit (@Memory.add_exists mem0 loc2 from2 to2).
    { i. inv ADD2. inv ADD. eapply DISJOINT.
      etrans; [eapply Memory.add_o; eauto|]. condtac; ss; eauto.
      des. subst. exploit Memory.add_get0; eauto. i. des. congr.
    }
    { inv ADD2. inv ADD. auto. }
    { inv ADD2. inv ADD. eauto. }
    i. des.
    exploit (@Memory.add_exists mem3 loc1 from1 to1).
    { i. revert GET2. erewrite Memory.add_o; eauto. condtac; ss.
      - des. subst. i. inv GET2.
        exploit Memory.add_get0; try exact ADD2; eauto.
        inv ADD2. inv ADD. symmetry. eapply DISJOINT.
        etrans; [eapply Memory.add_o; eauto|]. condtac; ss. des; congr.
      - guardH o. i. inv ADD1. inv ADD. eapply DISJOINT; eauto.
    }
    { inv ADD1. inv ADD. auto. }
    { inv ADD1. inv ADD. eauto. }
    i. des.
    esplits; eauto; cycle 1.
    { ii. inv H.
      exploit Memory.add_get0; try exact ADD2; eauto.
      erewrite Memory.add_o; eauto. condtac; s; i; des; congr.
    }
    cut (mem4 = mem2); [by i; subst; eauto|].
    apply Memory.ext. i.
    setoid_rewrite Memory.add_o; cycle 1; eauto.
    erewrite (@Memory.add_o mem3); eauto. erewrite (@Memory.add_o mem1); eauto.
    repeat (condtac; ss). des. subst.
    exploit Memory.add_get0; try exact ADD1; eauto. i. des.
    exploit Memory.add_get0; try exact ADD2; eauto. i. des.
    congr.
  Qed.

  Lemma add_remove
        mem0 loc1 from1 to1 msg1
        mem1 loc2 from2 to2 msg2
        mem2
        (LOCTS1: (loc1, to1) <> (loc2, to2))
        (ADD1: Memory.add mem0 loc1 from1 to1 msg1 mem1)
        (REMOVE2: Memory.remove mem1 loc2 from2 to2 msg2 mem2):
    exists mem1',
      <<REMOVE1: Memory.remove mem0 loc2 from2 to2 msg2 mem1'>> /\
      <<ADD2: Memory.add mem1' loc1 from1 to1 msg1 mem2>>.
  Proof.
    exploit (@Memory.remove_exists mem0 loc2 from2 to2).
    { hexploit Memory.remove_get0; eauto.
      erewrite Memory.add_o; eauto. condtac; ss; i; des; subst; eauto. congr.
    }
    i. des.
    exploit (@Memory.add_exists mem3 loc1 from1 to1);
      try by inv ADD1; inv ADD; eauto.
    { i. revert GET2. erewrite Memory.remove_o; eauto. condtac; ss.
      inv ADD1. inv ADD. eauto.
    }
    i. des.
    cut (mem4 = mem2); [by i; subst; eauto|].
    apply Memory.ext. i.
    erewrite Memory.add_o; eauto. erewrite Memory.remove_o; eauto.
    erewrite (@Memory.remove_o mem2); eauto. erewrite (@Memory.add_o mem1); eauto.
    repeat (condtac; ss). des. repeat subst. congr.
  Qed.

  Lemma add_remove_same
        mem0 loc1 from1 to1 msg1
        mem1 from2 msg2
        mem2
        (ADD1: Memory.add mem0 loc1 from1 to1 msg1 mem1)
        (REMOVE2: Memory.remove mem1 loc1 from2 to1 msg2 mem2):
    from1 = from2 /\ msg1 = msg2 /\ mem0 = mem2.
  Proof.
    exploit Memory.add_get0; eauto. i. des.
    exploit Memory.remove_get0; eauto. i. des.
    rewrite GET0 in *. inv GET1. splits; auto.
    apply Memory.ext. i.
    erewrite (@Memory.remove_o mem2); eauto. condtac; ss.
    - des. subst. ss.
    - erewrite (@Memory.add_o mem1); eauto. condtac; ss.
  Qed.

  Lemma remove_add
        mem0 loc1 from1 to1 msg1
        mem1 loc2 from2 to2 msg2
        mem2
        (REMOVE1: Memory.remove mem0 loc1 from1 to1 msg1 mem1)
        (ADD2: Memory.add mem1 loc2 from2 to2 msg2 mem2)
        (TS: Time.lt from1 to1)
        (LOCTS: loc1 <> loc2 \/ Interval.disjoint (from1, to1) (from2, to2)):
    exists mem1',
      <<ADD1: Memory.add mem0 loc2 from2 to2 msg2 mem1'>> /\
      <<REMOVE2: Memory.remove mem1' loc1 from1 to1 msg1 mem2>>.
  Proof.
    guardH LOCTS.
    exploit (@Memory.add_exists mem0 loc2 from2 to2 msg2).
    { i. exploit Memory.remove_get1; try exact GET2; eauto. i. des.
      { subst. unguard. des; ss. symmetry. ss. }
      exploit Memory.add_get1; try exact x0; eauto. i.
      exploit Memory.add_get0; eauto. i. des.
      exploit Memory.get_disjoint; [exact GET0|exact x1|]. i. des; ss. subst. congr.
    }
    { exploit Memory.add_ts; eauto. }
    { inv ADD2. inv ADD. ss. }
    i. des.
    esplits; eauto.
    exploit Memory.remove_get0; eauto. i. des.
    exploit Memory.add_get1; try exact GET; eauto. i.
    exploit Memory.remove_exists; try exact x1. i. des.
    cut (mem4 = mem2); try congr.
    apply Memory.ext. i.
    erewrite (@Memory.remove_o mem4); eauto.
    erewrite (@Memory.add_o mem3); eauto.
    erewrite (@Memory.add_o mem2); eauto.
    erewrite (@Memory.remove_o mem1); eauto.
    repeat (condtac; ss). des. subst. exfalso.
    unguard. des; ss.
    exploit Memory.add_ts; eauto. i.
    apply (LOCTS to2); econs; ss; refl.
  Qed.

  Lemma remove_remove
        promises0 loc1 from1 to1 msg1
        promises1 loc2 from2 to2 msg2
        promises2
        (REMOVE1: Memory.remove promises0 loc1 from1 to1 msg1 promises1)
        (REMOVE2: Memory.remove promises1 loc2 from2 to2 msg2 promises2):
    exists promises1',
      <<REMOVE1: Memory.remove promises0 loc2 from2 to2 msg2 promises1'>> /\
      <<REMOVE2: Memory.remove promises1' loc1 from1 to1 msg1 promises2>>.
  Proof.
    exploit Memory.remove_get0; try apply REMOVE2; eauto. i. des.
    revert GET. erewrite Memory.remove_o; eauto. condtac; ss. guardH o. i.
    exploit Memory.remove_exists; eauto. i. des.
    hexploit Memory.remove_get0; try apply REMOVE1; eauto. i. des.
    exploit (@Memory.remove_exists mem2 loc1 from1 to1 msg1); eauto.
    { erewrite Memory.remove_o; eauto. condtac; ss. des. subst. congr. }
    i. des.
    esplits; eauto.
    cut (mem0 = promises2); [by i; subst|].
    apply Memory.ext. i.
    erewrite Memory.remove_o; eauto. erewrite Memory.remove_o; eauto.
    erewrite (@Memory.remove_o promises2); eauto. erewrite (@Memory.remove_o promises1); eauto.
    repeat (condtac; ss).
  Qed.
End MemoryReorder.


From LogRel.AutoSubst Require Import core unscoped Ast Extra.
From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening GenericTyping LogicalRelation DeclarativeInstance Validity.
From LogRel.LogicalRelation Require Import Irrelevance Reflexivity Transitivity.

Set Universe Polymorphism.

Section Irrelevances.
Context `{GenericTypingProperties}.

Lemma VRirrelevant Γ {vsubst vsubst' veqsubst veqsubst'}
  (vr : VR Γ vsubst veqsubst) (vr' : VR Γ vsubst' veqsubst') :
  (forall Δ σ wfΔ wfΔ', vsubst Δ σ wfΔ <~> vsubst' Δ σ wfΔ') ×
  (forall Δ σ σ' wfΔ wfΔ' vs vs', veqsubst Δ σ σ' wfΔ vs <~> veqsubst' Δ σ σ' wfΔ' vs').
Proof.
  revert vsubst' veqsubst' vr'.  pattern Γ, vsubst, veqsubst, vr.
  apply VR_rect; clear Γ vsubst veqsubst vr.
  - intros ?? h. inversion h. split; reflexivity.
  - intros ?????? ih ?? h. inversion h.
    specialize (ih _ _ VΓad0); destruct ih as [ih1 ih2].
    split.
    + intros. split; intros []; unshelve econstructor.
      1,2: eapply ih1; eassumption.
      1,2: irrelevance.
    + intros; split; intros []; unshelve econstructor.
      1,3: eapply ih2; eassumption.
      1,2: irrelevance.
Qed.

Lemma irrelevanceSubst {Γ} (VΓ VΓ' : [||-v Γ]) {σ Δ} (wfΔ wfΔ' : [|- Δ]) :
  [Δ ||-v σ : Γ | VΓ | wfΔ] -> [Δ ||-v σ : Γ | VΓ' | wfΔ'].
Proof.
  apply (fst (VRirrelevant Γ VΓ.(VAd.adequate) VΓ'.(VAd.adequate))).
Qed.

Lemma irrelevanceSubstEq {Γ} (VΓ VΓ' : [||-v Γ]) {σ σ' Δ} (wfΔ wfΔ' : [|- Δ])
  (Vσ : [Δ ||-v σ : Γ | VΓ | wfΔ]) (Vσ' : [Δ ||-v σ : Γ | VΓ' | wfΔ']) :
  [Δ ||-v σ ≅ σ' : Γ | VΓ | wfΔ | Vσ] -> [Δ ||-v σ ≅ σ' : Γ | VΓ' | wfΔ' | Vσ'].
Proof.
  apply (snd (VRirrelevant Γ VΓ.(VAd.adequate) VΓ'.(VAd.adequate))).
Qed.

Set Printing Primitive Projection Parameters.

Lemma reflSubst {Γ} (VΓ : [||-v Γ]) : forall {σ Δ} (wfΔ : [|- Δ])
  (Vσ : [Δ ||-v σ : Γ | VΓ | wfΔ]),
  [Δ ||-v σ ≅ σ : Γ | VΓ | wfΔ | Vσ].
Proof.
  pattern Γ, VΓ; apply validity_rect; clear Γ VΓ.
  - constructor.
  - intros * ih. unshelve econstructor.
    1: apply ih.
    apply LREqTermRefl_. exact (validHead Vσ).
Qed.

Lemma symmetrySubstEq {Γ} (VΓ VΓ' : [||-v Γ]) : forall {σ σ' Δ} (wfΔ wfΔ' : [|- Δ])
  (Vσ : [Δ ||-v σ : Γ | VΓ | wfΔ]) (Vσ' : [Δ ||-v σ' : Γ | VΓ' | wfΔ']),
  [Δ ||-v σ ≅ σ' : Γ | VΓ | wfΔ | Vσ] -> [Δ ||-v σ' ≅ σ : Γ | VΓ' | wfΔ' | Vσ'].
Proof.
  revert VΓ'; pattern Γ, VΓ; apply validity_rect; clear Γ VΓ.
  - intros VΓ'. rewrite (invValidityEmpty VΓ'). constructor.
  - intros * ih VΓ'. pose proof (x := invValiditySnoc VΓ').
    destruct x as [lA'[ VΓ'' [VA' ->]]].
    intros ????? [tl hd] [tl' hd'] [tleq hdeq].
    unshelve econstructor.
    1: now eapply ih.
    eapply LRTmEqSym. cbn in *.
    revert hdeq. apply LRTmEqRedConv.
    eapply validTyExt. 2:eassumption.
    eapply irrelevanceSubst; eassumption.
Qed.

Lemma transSubstEq {Γ} (VΓ : [||-v Γ]) :
  forall {σ σ' σ'' Δ} (wfΔ : [|- Δ])
    (Vσ : [Δ ||-v σ : Γ | VΓ | wfΔ])
    (Vσ' : [Δ ||-v σ' : Γ | VΓ | wfΔ]),
    [Δ ||-v σ ≅ σ' : Γ | VΓ | wfΔ | Vσ] ->
    [Δ ||-v σ' ≅ σ'' : Γ | VΓ | wfΔ | Vσ'] ->
    [Δ ||-v σ ≅ σ'' : Γ | VΓ | wfΔ | Vσ].
Proof.
  pattern Γ, VΓ; apply validity_rect; clear Γ VΓ.
  - constructor.
  - intros * ih * [] []; unshelve econstructor.
    1: now eapply ih.
    eapply transEqTerm; tea.
    eapply LRTmEqRedConv; tea.
    unshelve eapply LRTyEqSym; tea.
    2: unshelve eapply validTyExt.
    7: eassumption.
    1: tea.
    now eapply validTail.
Qed.

Lemma irrelevanceValidity {Γ} : forall (VΓ VΓ' : [||-v Γ]) {l A},
  [Γ ||-v<l> A | VΓ] -> [Γ ||-v<l> A | VΓ'].
Proof.
  intros VΓ VΓ' l A [VA VAext]; unshelve econstructor; intros.
  - unshelve eapply VA. 2: eapply irrelevanceSubst. all:eassumption.
  - eapply VAext; [eapply irrelevanceSubst| eapply irrelevanceSubstEq]; eassumption.
Qed.

Lemma irrelevanceLift {l A F G Γ} (VΓ : [||-v Γ])
  (VF: [Γ ||-v<l> F | VΓ]) (VG: [Γ ||-v<l> G | VΓ])
  (VFeqG : [Γ ||-v<l> F ≅ G | VΓ | VF]) :
  [Γ ,, F ||-v<l> A | validSnoc VΓ VF] ->
  [Γ ,, G ||-v<l> A | validSnoc VΓ VG].
Proof.
  intros [VA VAext]; unshelve econstructor.
  - intros ??? [hd tl]. eapply VA.
    unshelve econstructor. 1: eassumption.
    eapply LRTmRedConv. 2: eassumption.
    eapply LRTyEqSym; unshelve eapply VFeqG; eassumption.
  - intros ???? [??] [??] [??]. eapply VAext.
    + unshelve econstructor. 1: eassumption.
      eapply LRTmRedConv. 2: eassumption.
      eapply LRTyEqSym; unshelve eapply VFeqG; eassumption.
    + unshelve econstructor. 1: eassumption.
      eapply LRTmEqRedConv. 2: eassumption.
      eapply LRTyEqSym; unshelve eapply VFeqG; eassumption.
Qed.

Lemma irrelevanceEq {Γ l A B} (VΓ VΓ' : [||-v Γ]) (VA : [Γ ||-v<l> A | VΓ]) (VA' : [Γ||-v<l> A | VΓ']) :
  [Γ ||-v< l > A ≅ B | VΓ | VA] -> [Γ ||-v< l > A ≅ B | VΓ' | VA'].
Proof.
  intros [h]; constructor; intros.
  irrelevanceRefl.
  unshelve apply h. 1:eassumption.
  eapply irrelevanceSubst; eassumption.
Qed.

Lemma irrelevanceEq' {Γ l A A' B} (VΓ VΓ' : [||-v Γ]) (VA : [Γ ||-v<l> A | VΓ]) (VA' : [Γ||-v<l> A' | VΓ']) : A = A' ->
  [Γ ||-v< l > A ≅ B | VΓ | VA] -> [Γ ||-v< l > A' ≅ B | VΓ' | VA'].
Proof.
  intros ->; now eapply irrelevanceEq.
Qed.

Lemma symValidEq {Γ l A B} {VΓ : [||-v Γ]} {VA : [Γ ||-v<l> A | VΓ]} (VB : [Γ ||-v<l> B | VΓ]) :
  [Γ ||-v<l> A ≅ B | VΓ | VA] -> [Γ ||-v<l> B ≅ A | VΓ | VB].
Proof.
  intros; constructor; intros.
  eapply LRTyEqSym; now eapply validTyEq.
  Unshelve. all: tea.
Qed.

Lemma transValidEq {Γ l A B C} {VΓ : [||-v Γ]}
  {VA : [Γ ||-v<l> A | VΓ]} {VB : [Γ ||-v<l> B | VΓ]} (VC : [Γ ||-v<l> C | VΓ]):
  [Γ ||-v<l> A ≅ B | VΓ | VA] -> [Γ ||-v<l> B ≅ C | VΓ | VB] -> [Γ ||-v<l> A ≅ C | VΓ | VA].
Proof.
  constructor; intros; eapply transEq; now eapply validTyEq.
  Unshelve. all: tea. now eapply validTy.
Qed.

Lemma irrelevanceTm {Γ l t A} (VΓ VΓ' : [||-v Γ]) (VA : [Γ ||-v<l> A | VΓ]) (VA' : [Γ||-v<l> A | VΓ']) :
  [Γ ||-v<l> t : A | VΓ | VA] -> [Γ ||-v<l> t : A | VΓ' | VA'].
Proof.
  intros [h1 h2]; unshelve econstructor.
  - intros. irrelevanceRefl.
    unshelve apply h1. 1:eassumption.
    eapply irrelevanceSubst; eassumption.
  - intros. irrelevanceRefl.
    unshelve eapply h2. 1: eassumption.
    1,2: eapply irrelevanceSubst; eassumption.
    eapply irrelevanceSubstEq; eassumption.
Qed.

Lemma irrelevanceTm' {Γ l t A A'} (VΓ VΓ' : [||-v Γ]) (VA : [Γ ||-v<l> A | VΓ]) (VA' : [Γ||-v<l> A' | VΓ']) :
  A = A' -> [Γ ||-v<l> t : A | VΓ | VA] -> [Γ ||-v<l> t : A' | VΓ' | VA'].
Proof.
  intros ->; now eapply irrelevanceTm.
Qed.

Lemma irrelevanceTmLift {l t A F G Γ} (VΓ : [||-v Γ])
  (VF: [Γ ||-v<l> F | VΓ]) (VG: [Γ ||-v<l> G | VΓ])
  (VFeqG : [Γ ||-v<l> F ≅ G | VΓ | VF])
  (VA : [Γ ,, F ||-v<l> A | validSnoc VΓ VF])
  (VA' : [Γ ,, G ||-v<l> A | validSnoc VΓ VG])  :
  [Γ ,, F ||-v<l> t : A | validSnoc VΓ VF | VA] ->
  [Γ ,, G ||-v<l> t : A | validSnoc VΓ VG | VA'].
Proof.
  intros [Vt Vtext]; unshelve econstructor.
  - intros ??? [hd tl]. irrelevanceRefl.
    unshelve eapply Vt; tea.
    unshelve econstructor; tea.
    eapply LRTmRedConv; tea.
    eapply LRTyEqSym; unshelve eapply VFeqG; eassumption.
  - intros ???? [??] [??] [??]. irrelevanceRefl.
    unshelve eapply Vtext; tea.
    + unshelve econstructor; tea.
      eapply LRTmRedConv; tea.
      eapply LRTyEqSym; unshelve eapply VFeqG; eassumption.
    + unshelve econstructor; tea.
      eapply LRTmRedConv; tea.
      eapply LRTyEqSym; unshelve eapply VFeqG; eassumption.
    + unshelve econstructor; tea.
      eapply LRTmEqRedConv; tea.
      eapply LRTyEqSym; unshelve eapply VFeqG; eassumption.
Qed.

Lemma irrelevanceTmEq {Γ l t u A} (VΓ VΓ' : [||-v Γ]) (VA : [Γ ||-v<l> A | VΓ]) (VA' : [Γ||-v<l> A | VΓ']) :
  [Γ ||-v<l> t ≅ u : A | VΓ | VA] -> [Γ ||-v<l> t ≅ u : A | VΓ' | VA'].
Proof.
  intros [h]; constructor; intros; irrelevanceRefl.
  unshelve apply h; tea.
  eapply irrelevanceSubst; eassumption.
Qed.

Lemma irrelevanceTmEq' {Γ l t u A A'} (VΓ VΓ' : [||-v Γ]) (VA : [Γ ||-v<l> A | VΓ]) (VA' : [Γ||-v<l> A' | VΓ']) :
  A = A' -> [Γ ||-v<l> t ≅ u : A | VΓ | VA] -> [Γ ||-v<l> t ≅ u : A' | VΓ' | VA'].
Proof.
  intros ->; now eapply irrelevanceTmEq.
Qed.

Lemma symValidTmEq {Γ l t u A} {VΓ : [||-v Γ]} {VA : [Γ ||-v<l> A | VΓ]} :
  [Γ ||-v<l> t ≅ u : A| VΓ | VA] -> [Γ ||-v<l> u ≅ t : A | VΓ | VA].
Proof.
  intros; constructor; intros.
  eapply LRTmEqSym; now eapply validTmEq.
Qed.

Lemma transValidTmEq {Γ l t u v A} {VΓ : [||-v Γ]}
  {VA : [Γ ||-v<l> A | VΓ]} :
  [Γ ||-v<l> t ≅ u : A | VΓ | VA] ->
  [Γ ||-v<l> u ≅ v : A | VΓ | VA] ->
  [Γ ||-v<l> t ≅ v : A | VΓ | VA].
Proof.
  constructor; intros; eapply transEqTerm; now eapply validTmEq.
Qed.

Lemma irrelevanceSubstExt {Γ} (VΓ : [||-v Γ]) {σ σ' Δ} (wfΔ : [|- Δ]) :
  σ =1 σ' -> [Δ ||-v σ : Γ | VΓ | wfΔ] -> [Δ ||-v σ' : Γ | VΓ | wfΔ].
Proof.
  revert σ σ'; pattern Γ, VΓ; apply validity_rect; clear Γ VΓ.
  - constructor.
  - intros ????? ih ?? eq.  unshelve econstructor.
    + eapply ih. 2: now eapply validTail.
      now rewrite eq.
    + rewrite <- (eq var_zero).
      pose proof (validHead X).
      irrelevance. now rewrite eq.
Qed.

Lemma irrelevanceSubstEqExt {Γ} (VΓ : [||-v Γ]) {σ1 σ1' σ2 σ2' Δ}
  (wfΔ : [|- Δ]) (eq1 : σ1 =1 σ1') (eq2 : σ2 =1 σ2')
  (Vσ1 : [Δ ||-v σ1 : Γ | VΓ | wfΔ]) :
  [Δ ||-v σ1 ≅ σ2 : Γ | VΓ | wfΔ | Vσ1] ->
  [Δ ||-v σ1' ≅ σ2' : Γ | VΓ | wfΔ | irrelevanceSubstExt VΓ wfΔ eq1 Vσ1].
Proof.
  revert σ1 σ1' σ2 σ2' eq1 eq2 Vσ1; pattern Γ, VΓ; apply validity_rect; clear Γ VΓ.
  - constructor.
  - intros ????? ih ???? eq1 eq2 ? X. unshelve econstructor.
    + eapply irrelevanceSubstEq.
      unshelve eapply ih.
      6: now eapply eqTail.
      all: now (rewrite eq1 + rewrite eq2).
    + rewrite <- (eq1 var_zero); rewrite <- (eq2 var_zero).
      pose proof (eqHead X).
      irrelevance.
      rewrite eq1; reflexivity.
Qed.

End Irrelevances.

Ltac irrValid :=
  match goal with
  | [_ : _ |- [||-v _]] => idtac
  | [_ : _ |- [ _ ||-v _ : _ | _ | _]] => eapply irrelevanceSubst
  | [_ : _ |- [ _ ||-v _ ≅ _ : _ | _ | _ | _]] => eapply irrelevanceSubstEq
  | [_ : _ |- [_ ||-v<_> _ | _]] => eapply irrelevanceValidity
  | [_ : _ |- [_ ||-v<_> _ ≅ _ | _ | _]] => eapply irrelevanceEq
  | [_ : _ |- [_ ||-v<_> _ : _ | _ | _]] => eapply irrelevanceTm
  | [_ : _ |- [_ ||-v<_> _ ≅ _ : _ | _ | _]] => eapply irrelevanceTmEq
  end; eassumption.


Require Import VST.msl.seplog.
Require Import VST.msl.log_normalize.
Require Import CertiGraph.lib.Coqlib.
Require Import CertiGraph.lib.Ensembles_ext.
Require Import CertiGraph.lib.EquivDec_ext.
Require Import Coq.Lists.List.
Require Import CertiGraph.msl_ext.ramification_lemmas.
Require Import CertiGraph.graph.graph_model.
Require Import CertiGraph.graph.path_lemmas.
Require Import CertiGraph.graph.graph_gen.
Require Import CertiGraph.graph.graph_relation.
Require Import CertiGraph.graph.subgraph2.
Require Import CertiGraph.graph.reachable_ind.
Require Import CertiGraph.graph.spanning_tree.
Require Import CertiGraph.graph.BinGraph.
Require Import CertiGraph.graph.MathGraph.
Require Import CertiGraph.graph.FiniteGraph.
Require Import CertiGraph.msl_application.Graph.
Require Import CertiGraph.msl_application.GraphBin.
Require Import CertiGraph.msl_application.GraphBin_Mark.
Require CertiGraph.graph.weak_mark_lemmas.
Import CertiGraph.graph.weak_mark_lemmas.WeakMarkGraph.

(* TODO: Put some pure lemmas into some file like: graph/bi_spanning. *)

#[export] Instance MGS: MarkGraphSetting bool.
  apply (Build_MarkGraphSetting bool
          (eq true));
  intros.
  + destruct x; [left | right]; congruence.
Defined.

Section SPATIAL_GRAPH_DISPOSE_BIN.

  Context {pSGG_Bin: pPointwiseGraph_Graph_Bin}.
  Context {sSGG_Bin: sPointwiseGraph_Graph_Bin bool unit}.

  Existing Instances maGraph binGraph finGraph.

  Local Open Scope logic.
  Local Coercion Graph_LGraph: Graph >-> LGraph.
  Local Coercion LGraph_SGraph: LGraph >-> SGraph.
  Local Identity Coercion Graph_GeneralGraph: Graph >-> GeneralGraph.
  Local Identity Coercion LGraph_LabeledGraph: LGraph >-> LabeledGraph.
  Local Identity Coercion SGraph_PointwiseGraph: SGraph >-> PointwiseGraph.
  Local Coercion pg_lg: LabeledGraph >-> PreGraph.

  Notation Graph := (@Graph pSGG_Bin bool unit unit).

  Lemma vgamma_is_true: forall (g : Graph) (x l r : addr), vgamma g x = (true, l, r) -> marked g x.
  Proof. intros. simpl in H. simpl. destruct (vlabel g x) eqn:? . auto. inversion H. Qed.

  Lemma vgamma_is_false: forall (g : Graph) (x l r : addr), vgamma g x = (false, l, r) -> unmarked g x.
  Proof.
    intros. simpl in H. hnf. unfold Ensembles.In. simpl. intro.
    destruct (vlabel g x) eqn:? . inversion H. simpl in H0. inversion H0.
  Qed.

  Lemma edge_spanning_tree_left_null:
    forall (g: Graph) x d l r, vvalid g x -> vgamma g x = (d, l, r) -> (marked g) l ->
                               edge_spanning_tree g (x, L) (Graph_gen_left_null g x).
  Proof.
    intros. assert (l = dst g (x, L)) by (simpl in H0; inversion H0; auto).
    hnf. change (lg_gg g) with (g: LGraph). destruct (node_pred_dec (marked g) (dst g (x, L))). 2: subst l; exfalso; auto.
    split.
    + hnf. simpl. split; [| split; [|split; [| split]]]; [tauto | tauto | tauto | | ].
      - intros. unfold updateEdgeFunc.
        destruct (equiv_dec (x, L) e); intuition.
      - right. unfold updateEdgeFunc.
        destruct (equiv_dec (x, L) (x, L)); intuition.
        * apply (valid_not_null g) in H3; auto. reflexivity.
        * apply (@left_valid _ _ _ _ _ _ g (binGraph g)) in H; auto.
    + simpl. tauto.
  Qed.

  Lemma graph_gen_left_null_ramify:
    forall (g: Graph) (x : addr) d (l r : addr),
      vvalid g x -> vgamma g x = (d, l, r) ->
      (reachable_vertices_at x g : pred) |-- vertex_at x (d, l, r) * (vertex_at x (d, null, r) -* vertices_at (reachable g x) (Graph_gen_left_null g x)).
  Proof.
    intros.
    replace (@vertex_at _ _ _ _ _ SGP x (d, l, r)) with (graph_vcell g x).
    2: {
      unfold graph_vcell; simpl.
      simpl in H0; rewrite H0; auto.
    }
    replace (@vertex_at _ _ _ _ _ SGP x (d, null, r)) with (graph_vcell (Graph_gen_left_null g x) x).
    2: {
      unfold graph_vcell; simpl.
      unfold updateEdgeFunc.
      destruct_eq_dec (x, L) (x, L). 2: exfalso; auto.
      destruct_eq_dec (x, L) (x, R). inversion H2.
      simpl in H0; inversion H0; auto.
    }
    apply vertices_at_ramif_1; auto.
    eexists; split; [| split].
    + apply Ensemble_join_Intersection_Complement.
      - unfold Included, Ensembles.In; intros; subst; apply reachable_by_refl; auto.
      - intros; destruct_eq_dec x x0; auto.
    + apply Ensemble_join_Intersection_Complement.
      - unfold Included, Ensembles.In; intros; subst; apply reachable_by_refl; auto.
      - intros; destruct_eq_dec x x0; auto.
    + rewrite vertices_identical_spec.
      simpl; intros.
      change (lg_gg g) with (g: LGraph).
      rewrite Intersection_spec in H1.
      destruct H1; unfold Complement, Ensembles.In in H2.
      simpl. unfold updateEdgeFunc.
      destruct_eq_dec (x, L) (x0, L).
      - inversion H3. exfalso; auto.
      - destruct_eq_dec (x, L) (x0, R). inversion H4. auto.
  Qed.

  Lemma graph_gen_left_null_ramify_weak:
    forall (g: Graph) (x : addr) d (l r : addr),
      vvalid g x -> vgamma g x = (d, l, r) ->
      (reachable_vertices_at x g : pred) |-- vertex_at x (d, l, r) * (vertex_at x (d, null, r) -* (reachable_vertices_at x (Graph_gen_left_null g x) * TT)).
  Proof.
    intros. pose proof (graph_gen_left_null_ramify g x d l r H H0).
    apply log_normalize.sepcon_weaken with (vertex_at x (d, null, r) -* vertices_at (reachable g x) (Graph_gen_left_null g x)); auto.
    apply wand_derives; auto. unfold reachable_vertices_at.
    cut ((vertices_at (reachable g x) (Graph_gen_left_null g x) : pred)
                     |-- vertices_at (reachable (Graph_gen_left_null g x) x)
                     (Graph_gen_left_null g x) * TT). auto. unfold vertices_at.
    apply iter_sepcon.pred_sepcon_prop_true_weak.
    - apply Graph_reachable_dec, weak_valid_vvalid_dec. right.
      unfold Graph_gen_left_null. simpl. apply H.
    - intro y. unfold Graph_gen_left_null. simpl.
      apply is_partial_graph_reachable, pregraph_gen_dst_is_partial_graph.
      apply invalid_null.
  Qed.

  Lemma graph_ramify_aux1_left: forall (g: Graph) x d l r,
      vvalid g x -> vgamma g x = (d, l, r) ->
      (reachable_vertices_at x g : pred) |-- reachable_vertices_at l g *
      (ALL  g' : Graph , !!spanning_tree g l g' --> (vertices_at (reachable g l) g' -* vertices_at (reachable g x) g')).
  Proof.
    intros. eapply vertices_at_ramif_xQ; auto.
    eexists; split; [| split].
    + eapply Prop_join_reachable_left; eauto.
    + intros. eapply Prop_join_reachable_left; eauto.
    + intros; rewrite vertices_identical_spec.
      intros.
      rewrite Intersection_spec in H2. unfold Complement, Ensembles.In in H2.
      destruct H2. simpl. f_equal; [f_equal |].
      - apply vlabel_eq. destruct H1. specialize (H1 x0).
        pose proof reachable_by_is_reachable g l x0 (unmarked g).
        tauto.
      - destruct H1 as [_ [? _]]. hnf in H1. simpl in H1.
        unfold predicate_weak_evalid in H1. destruct H1 as [_ [? [_ ?]]].
        specialize (H1 (x0, L)). specialize (H4 (x0, L)).
        assert (src g (x0, L) = x0)
          by (apply (@left_sound _ _ _ _ _ _ g (binGraph g) x0); apply reachable_foot_valid in H2; auto).
        change (lg_gg g) with (g: LGraph) in *.
        rewrite H5 in *.
        assert (evalid g (x0, L) /\ ~ g |= l ~o~> x0 satisfying (unmarked g)). {
          split.
          + apply reachable_foot_valid in H2.
            apply (@left_valid _ _ _ _ _ _ g (binGraph g)); auto.
          + intro; apply H3; apply reachable_by_is_reachable in H6; auto.
        } apply H4; intuition.
      - destruct H1 as [_ [? _]]. hnf in H1. simpl in H1.
        unfold predicate_weak_evalid in H1. destruct H1 as [_ [? [_ ?]]].
        specialize (H1 (x0, R)). specialize (H4 (x0, R)).
        assert (src g (x0, R) = x0)
          by (apply (@right_sound _ _ _ _ _ _ g (binGraph g) x0); apply reachable_foot_valid in H2; auto).
        change (lg_gg g) with (g: LGraph) in *.
        rewrite H5 in *.
        assert (evalid g (x0, R) /\ ~ g |= l ~o~> x0 satisfying (unmarked g)). {
          split.
          + apply reachable_foot_valid in H2.
            apply (@right_valid _ _ _ _ _ _ g (binGraph g)); auto.
          + intro; apply H3; apply reachable_by_is_reachable in H6; auto.
        } apply H4; intuition.
  Qed.

  Lemma totally_unmarked_root_ST_reachable_eq: forall (g1 g2: Graph) root,
      totally_unmarked g1 root -> spanning_tree g1 root g2 ->
      vertices_at (reachable g1 root) g2 = reachable_vertices_at root g2.
  Proof.
    intros. apply vertices_at_Same_set. rewrite Same_set_spec. hnf.
    apply spanning_tree_totally_unmarked_root_reachable; auto. intros.
    apply Graph_reachable_by_dec, weak_valid_vvalid_dec; right; auto.
  Qed.

  Lemma totally_unmarked_parent_ST_reachable_eq: forall (g1 g2: Graph) x l r,
      vvalid g1 x -> vgamma g1 x = (true, l, r) -> totally_unmarked g1 l ->
      spanning_tree g1 l g2 ->
      vertices_at (reachable g1 x) g2 = reachable_vertices_at x g2.
  Proof.
    intros. apply vertices_at_Same_set. rewrite Same_set_spec. hnf.
    assert (l = dst (lg_gg g1) (x, L)) by (simpl in H0; inversion H0; auto).
    apply spanning_tree_totally_unmarked_parent_reachable with (e := (x, L));
      auto; try rewrite <- H3; auto.
      - hnf. split.
        + apply (@left_valid _ _ _ _ _ _ g1 (binGraph g1)); auto.
        + apply (@left_sound _ _ _ _ _ _ g1 (binGraph g1) x); auto.
      - apply vgamma_is_true in H0. auto.
      - intros; apply Graph_reachable_by_dec, weak_valid_vvalid_dec; right; auto.
  Qed.
(*
  Lemma graph_ramify_aux1_left_weak: forall (g: Graph) x l r,
      vvalid g x -> vgamma g x = (true, l, r) -> totally_unmarked g l ->
      (reachable_vertices_at x g : pred) |-- reachable_vertices_at l g *
      (ALL  g' : Graph , !!spanning_tree g l g' --> (reachable_vertices_at l g' -* reachable_vertices_at x g')).
  Proof.
    intros. pose proof (@graph_ramify_aux1_left g x true l r H H0).
    eapply log_normalize.sepcon_weaken. 2: apply H2. clear H2.
    apply allp_derives. intros p. destruct p as [? g2]. simpl.
    rewrite <- imp_andp_adjoint. apply derives_extract_prop'. intros.
    rewrite prop_imp; auto. apply wand_derives.
    - rewrite <- totally_unmarked_root_ST_reachable_eq; auto.
    - rewrite (totally_unmarked_parent_ST_reachable_eq _ _ _ l r); auto.
  Qed.
*)
  Lemma edge_spanning_tree_left_vvalid: forall (g1 g2: Graph) x n,
      vvalid g1 x -> edge_spanning_tree g1 (x, L) g2 -> (vvalid g1 n <-> vvalid g2 n).
  Proof.
    intros. apply (edge_spanning_tree_vvalid g1 g2 (x, L) n); auto.
  Qed.

  Lemma edge_spanning_tree_right_vvalid: forall (g1 g2: Graph) x n,
      vvalid g1 x -> edge_spanning_tree g1 (x, R) g2 -> (vvalid g1 n <-> vvalid g2 n).
  Proof.
    intros. apply (edge_spanning_tree_vvalid g1 g2 (x, R) n); auto.
  Qed.

  Lemma edge_spanning_tree_left_reachable_vvalid: forall (g1 g2: Graph) x d l r,
      vvalid g1 x -> vgamma g1 x = (d, l, r) -> edge_spanning_tree g1 (x, L) g2 -> Included (reachable g1 x) (vvalid g2).
  Proof.
    intros. assert (x = src g1 (x, L)) by (symmetry; apply (@left_sound _ _ _ _ _ _ g1 (binGraph g1) x); auto).
    rewrite H2. apply edge_spanning_tree_reachable_vvalid; auto.
  Qed.

  Lemma edge_spanning_tree_left_vgamma: forall (g1 g2: Graph) x l r,
      vvalid g1 x -> vgamma g1 x = (true, l, r) -> edge_spanning_tree g1 (x, L) g2 -> exists l', vgamma g2 x = (true, l', r).
  Proof.
    intros. simpl. exists (dst g2 (x, L)).
    assert (Hvg2: vvalid g2 x) by (rewrite <- edge_spanning_tree_left_vvalid; eauto).
    unfold edge_spanning_tree in H1.
    change (lg_gg g1) with (g1: LGraph) in H1.
    destruct (node_pred_dec (marked g1) (dst g1 (x, L))).
    + destruct H1 as [[_ [_ [_ [? _]]]] ?]. simpl in H0, H2. inversion H0.
      rewrite H4. symmetry in H4. rewrite H2 in H4.
      change (lg_gg g2) with (g2: LGraph) in H4.
      rewrite <- H4. f_equal. symmetry. apply H1.
      - intro. inversion H3.
      - apply (@right_valid _ _ _ _ _ _ g1 (binGraph g1)) in H; auto.
      - apply (@right_valid _ _ _ _ _ _ g2 (binGraph g2)) in Hvg2; auto.
    + destruct H1 as [? [[_ [_ [_ ?]]] _]].
      assert (marked g1 x) by (simpl in *; inversion H0; auto).
      assert (~ g1 |= dst g1 (x, L) ~o~> x satisfying (unmarked g1)) by (intro HS; apply reachable_by_foot_prop in HS; auto).
      assert (marked g2 x) by (specialize (H1 x); tauto).
      simpl in H5. rewrite <- H5. f_equal.
      simpl in H2. unfold predicate_weak_evalid in H2.
      simpl in H0. inversion H0. symmetry.
      change (lg_gg g1) with (g1: LGraph) in *.
      change (lg_gg g2) with (g2: LGraph) in *.
      apply H2; split.
      - apply (@right_valid _ _ _ _ _ _ g1 (binGraph g1) x); auto.
      - rewrite (@right_sound _ _ _ _ _ _ g1 (binGraph g1) x); auto.
      - apply (@right_valid _ _ _ _ _ _ g2 (binGraph g2) x); auto.
      - rewrite (@right_sound _ _ _ _ _ _ g2 (binGraph g2) x); auto.
  Qed.

  Lemma spanning_tree_left_reachable:
    forall (g1 g2: Graph) x l r,
      vvalid g1 x -> vgamma g1 x = (true, l, r) ->
      spanning_tree g1 l g2 -> Included (reachable g2 r) (reachable g1 x).
  Proof.
    intros. intro v. unfold Ensembles.In . intros.
    assert (X: ReachDecidable g1 l (unmarked g1)). {
      apply Graph_reachable_by_dec.
      apply weak_valid_vvalid_dec.
      apply (gamma_left_weak_valid g1 x true l r); auto.
    } destruct (X v).
    + apply reachable_by_is_reachable in r0. apply edge_reachable_by with l; auto.
      split; [|split]; auto.
      - apply reachable_head_valid in r0. auto.
      - simpl in H0. inversion H0. exists (x, L); auto.
        * apply (@left_valid _ _ _ _ _ _ g1 (binGraph g1)); auto.
        * apply (@left_sound _ _ _ _ _ _ g1 (binGraph g1)); auto.
    + apply edge_reachable_by with r; auto.
      - split; [|split]; auto.
        * apply reachable_head_valid in H2.
          rewrite (spanning_tree_vvalid g1 l g2); auto.
        * rewrite (gamma_step g1 x true l r); auto.
      - apply (spanning_tree_not_reachable g1 l g2 r v) in H2; auto.
        rewrite reachable_by_eq_partialgraph_reachable in H2.
        destruct H1 as [? [? ?]]. rewrite <- H3 in H2.
        rewrite <- reachable_by_eq_partialgraph_reachable in H2.
        apply reachable_by_is_reachable in H2. apply H2.
  Qed.

  Lemma edge_spanning_tree_left_reachable:
    forall (g1 g2: Graph) x l r,
      vvalid g1 x -> vgamma g1 x = (true, l, r) ->
      edge_spanning_tree g1 (x, L) g2 -> Included (reachable g2 r) (reachable g1 x).
  Proof.
    intros. assert (Hv: vvalid g2 r -> vvalid g1 r). {
      intros. rewrite (edge_spanning_tree_left_vvalid g1 g2 x r); auto.
    } hnf in H1.
    assert (l = dst g1 (x, L))
      by (simpl in H0; inversion H0; auto).
    change (lg_gg g1) with (g1: LGraph) in *.
    rewrite <- H2 in H1. destruct (node_pred_dec (marked g1) l).
    + destruct H1 as [[? [? [? [? ?]]]] ?]. intro v. unfold Ensembles.In .
      intros. apply edge_reachable_by with r; auto.
      - split; [|split]; auto.
        * apply Hv. apply reachable_head_valid in H8; auto.
        * rewrite (gamma_step g1 x true l r); auto.
      - change (g1 |= r ~o~> v satisfying (fun _ : addr => True))
        with (reachable g1 r v).
        rewrite reachable_ind_reachable in H8. clear H0. induction H8.
        * rewrite reachable_ind_reachable. constructor. rewrite H1; auto.
        * destruct H0 as [? [? ?]]. apply edge_reachable with y.
          apply IHreachable. rewrite H1; auto.
          split; [|split]; [rewrite H1; auto .. |]. rewrite step_spec in H10 |- *.
          destruct H10 as [e [? [? ?]]]. exists e.
          assert (e <> (x, L)) by (intro; subst; destruct H6; [|destruct H2]; auto).
          specialize (H3 _ H13). specialize (H4 _ H13). specialize (H5 _ H13).
          subst x0. subst y. intuition.
    + apply (spanning_tree_left_reachable g1 g2 x l r); auto.
  Qed.

  Lemma Prop_join_EST_right: forall (g1 g2: Graph) x l r,
      vvalid g1 x -> vgamma g1 x = (true, l, r) ->
      edge_spanning_tree g1 (x, L) g2 ->
      Prop_join (reachable g2 r)
                (Intersection _ (reachable g1 x) (Complement addr (reachable g2 r)))
                (reachable g1 x).
  Proof.
    intros. apply Ensemble_join_Intersection_Complement.
    + eapply edge_spanning_tree_left_reachable; eauto.
    + intros.
      destruct (edge_spanning_tree_left_vgamma g1 g2 x l r H H0 H1) as [l' ?].
      apply gamma_right_weak_valid in H2.
      - apply decidable_prop_decidable, Graph_reachable_dec,
        weak_valid_vvalid_dec; auto.
      - apply (edge_spanning_tree_left_reachable_vvalid g1 g2 x true l r); auto.
        unfold Ensembles.In . apply reachable_by_refl; auto.
  Qed.

  Lemma graph_ramify_aux1_right: forall (g1 g2: Graph) x l r,
      vvalid g1 x -> vgamma g1 x = (true, l, r) ->
      edge_spanning_tree g1 (x, L) g2 ->
      (vertices_at (reachable g1 x) g2: pred) |-- reachable_vertices_at r g2 *
      (ALL  g' : Graph ,
                !!spanning_tree g2 r g' -->
                  (vertices_at (reachable g2 r) g' -*
                               vertices_at (reachable g1 x) g')).
  Proof.
    intros. eapply vertices_at_ramif_xQ; auto.
    eexists; split; [| split].
    + eapply Prop_join_EST_right; eauto.
    + intros. eapply Prop_join_EST_right; eauto.
    + intros; rewrite vertices_identical_spec.
      intros. simpl.
      rewrite Intersection_spec in H3; unfold Complement, Ensembles.In in H3.
      destruct H3. f_equal; [f_equal |].
      - apply vlabel_eq. destruct H2 as [? _]. specialize (H2 x0).
        pose proof reachable_by_is_reachable g2 r x0 (unmarked g2).
        tauto.
      - destruct H2 as [_ [? _]]. hnf in H2. simpl in H2.
        unfold predicate_weak_evalid in H2. destruct H2 as [_ [? [_ ?]]].
        specialize (H2 (x0, L)). specialize (H5 (x0, L)).
        assert (src g2 (x0, L) = x0).
        1: {
          apply (@left_sound _ _ _ _ _ _ g2 (binGraph g2) x0).
          rewrite <- (edge_spanning_tree_left_vvalid g1 g2 x x0 H H1).
          apply reachable_foot_valid in H3; auto.
        }
        change (lg_gg g2) with (g2: LGraph) in *.
        rewrite H6 in *.
        assert (evalid g2 (x0, L) /\ ~ g2 |= r ~o~> x0 satisfying (unmarked g2)). {
          split.
          + apply reachable_foot_valid in H3.
            apply (@left_valid _ _ _ _ _ _ g2 (binGraph g2)).
            rewrite <- (edge_spanning_tree_left_vvalid g1 g2 x); eauto.
          + intro; apply H4; apply reachable_by_is_reachable in H7; auto.
        } apply H5; intuition.
      - destruct H2 as [_ [? _]]. hnf in H2. simpl in H2.
        unfold predicate_weak_evalid in H2. destruct H2 as [_ [? [_ ?]]].
        specialize (H2 (x0, R)). specialize (H5 (x0, R)).
        assert (src g2 (x0, R) = x0).
        1: {
          apply (@right_sound _ _ _ _ _ _ g2 (binGraph g2) x0).
          rewrite <- (edge_spanning_tree_left_vvalid g1 g2 x x0 H H1).
          apply reachable_foot_valid in H3; auto.
        }
        change (lg_gg g2) with (g2: LGraph) in *.
        rewrite H6 in *.
        assert (evalid g2 (x0, R) /\ ~ g2 |= r ~o~> x0 satisfying (unmarked g2)). {
          split.
          + apply reachable_foot_valid in H3.
            apply (@right_valid _ _ _ _ _ _ g2 (binGraph g2)).
            rewrite <- (edge_spanning_tree_left_vvalid g1 g2 x); eauto.
          + intro; apply H4; apply reachable_by_is_reachable in H7; auto.
        } apply H5; intuition.
  Qed.

  Lemma graph_gen_right_null_ramify: forall (g1 g2: Graph) (x : addr) d (l r : addr),
      vvalid g1 x -> vgamma g2 x = (d, l, r) ->
      (vertices_at (reachable g1 x) g2 : pred) |--
                  vertex_at x (d, l, r) * (vertex_at x (d, l, null) -* vertices_at (reachable g1 x) (Graph_gen_right_null g2 x)).
  Proof.
    intros.
    replace (@vertex_at _ _ _ _ _ SGP x (d, l, r)) with (graph_vcell g2 x).
    2: {
      unfold graph_vcell; simpl.
      simpl in H0; rewrite H0; auto.
    }
    replace (@vertex_at _ _ _ _ _ SGP x (d, l, null)) with (graph_vcell (Graph_gen_right_null g2 x) x).
    2: {
      unfold graph_vcell; simpl.
      unfold updateEdgeFunc.
      destruct_eq_dec (x, R) (x, L). inversion H1.
      destruct_eq_dec (x, R) (x, R). 2: exfalso; apply H2; auto.
      simpl in H0; inversion H0; auto.
    }
    apply vertices_at_ramif_1; auto.
    eexists; split; [| split].
    + apply Ensemble_join_Intersection_Complement.
      - unfold Included, Ensembles.In; intros; subst; apply reachable_by_refl; auto.
      - intros; destruct_eq_dec x x0; auto.
    + apply Ensemble_join_Intersection_Complement.
      - unfold Included, Ensembles.In; intros; subst; apply reachable_by_refl; auto.
      - intros; destruct_eq_dec x x0; auto.
    + rewrite vertices_identical_spec.
      simpl; intros.
      change (lg_gg g2) with (g2: LGraph).
      rewrite Intersection_spec in H1.
      destruct H1; unfold Complement, Ensembles.In in H2.
      simpl. unfold updateEdgeFunc.
      destruct_eq_dec (x, R) (x0, L).
      - inversion H3.
      - destruct_eq_dec (x, R) (x0, R).
        * inversion H4. exfalso; auto.
        * auto.
  Qed.

  Lemma graph_gen_right_null_ramify_weak: forall (g2: Graph) (x : addr) d (l r : addr),
      vvalid g2 x -> vgamma g2 x = (d, l, r) ->
      (reachable_vertices_at x g2 : pred) |-- vertex_at x (d, l, r) * (vertex_at x (d, l, null) -* (reachable_vertices_at x (Graph_gen_right_null g2 x) * TT)).
  Proof.
    intros. pose proof (graph_gen_right_null_ramify g2 g2 x d l r H H0).
    apply log_normalize.sepcon_weaken with (vertex_at x (d, l, null) -* vertices_at (reachable g2 x) (Graph_gen_right_null g2 x)); auto.
    apply wand_derives; auto. unfold reachable_vertices_at.
    cut ((vertices_at (reachable g2 x) (Graph_gen_right_null g2 x): pred)
           |-- vertices_at (reachable (Graph_gen_right_null g2 x) x)
           (Graph_gen_right_null g2 x) * TT). auto. unfold vertices_at.
    apply iter_sepcon.pred_sepcon_prop_true_weak.
    - apply Graph_reachable_dec, weak_valid_vvalid_dec. right.
      unfold Graph_gen_left_null. simpl. apply H.
    - intro y. unfold Graph_gen_left_null. simpl.
      apply is_partial_graph_reachable, pregraph_gen_dst_is_partial_graph.
      apply invalid_null.
  Qed.

  Lemma edge_spanning_tree_right_null:
    forall (g: Graph) x d l r, vvalid g x -> vgamma g x = (d, l, r) -> (marked g) r ->
                               edge_spanning_tree g (x, R) (Graph_gen_right_null g x).
  Proof.
    intros. assert (r = dst g (x, R)) by (simpl in H0; inversion H0; auto).
    hnf.
    change (lg_gg g) with (g: LGraph). destruct (node_pred_dec (marked g) (dst g (x, R))). 2: subst r; exfalso; auto.
    split.
    + hnf. simpl. split; [| split; [|split; [| split]]]; [tauto | tauto | tauto | | ].
      - intros. unfold updateEdgeFunc.
        destruct (equiv_dec (x, R) e); intuition.
      - right. split; auto. unfold updateEdgeFunc.
        destruct (equiv_dec (x, R) (x, R)); intuition.
        * apply (valid_not_null g) in H3; auto. reflexivity.
        * split; auto. apply (@right_valid _ _ _ _ _ _ g (binGraph g)) in H; auto.
    + simpl. tauto.
  Qed.

  Lemma edge_spanning_tree_spanning_tree: forall (g g1 g2 g3 : Graph) x l r,
      vvalid g x -> vvalid g1 x -> vvalid g2 x ->
      vgamma g x = (false, l, r) ->
      vgamma g1 x = (true, l, r) ->
      mark1 x g g1 ->
      edge_spanning_tree g1 (x, L) g2 ->
      edge_spanning_tree g2 (x, R) g3 ->
      spanning_tree g x g3.
  Proof.
    intros.
    apply (spanning_list_spanning_tree2 _ g1 _ _ (x, L) (x, R)); auto; intros.
    + intro. inversion H7.
    + pose proof (only_two_edges x e H). simpl in H7 |-* .
      split; intros.
      - destruct H8 as [? | [? | ?]]; [subst e..|exfalso; auto].
        * split; [|intuition]. apply (@left_valid _ _ _ _ _ _ g (binGraph g)); auto.
        * split; [|intuition]. apply (@right_valid _ _ _ _ _ _ g (binGraph g)); auto.
      - destruct H8. intuition.
    + apply Graph_reachable_by_dec. apply weak_valid_vvalid_dec. pose proof H3.
      simpl in H3. inversion H3. subst l.
      apply (gamma_left_weak_valid g1 x true (dst g1 (x, L)) r); auto.
    + unfold unmarked. rewrite negateP_spec. unfold marked. simpl. simpl in H2.
      inversion H2.
      change (lg_gg g) with (g: LGraph).
      rewrite H8. intuition.
    + apply spanning_list_cons with g2; auto.
      apply spanning_list_cons with g3; auto.
      apply spanning_list_nil. auto.
  Qed.

End SPATIAL_GRAPH_DISPOSE_BIN.


Require Import HoareDef MutHeader MutMain0 MutMain1 SimModSem.
Require Import Coqlib.
Require Import ImpPrelude.
Require Import Skeleton.
Require Import PCM.
Require Import ModSem Behavior.
Require Import Relation_Definitions.

(*** TODO: export these in Coqlib or Universe ***)
Require Import Relation_Operators.
Require Import RelationPairs.
From ITree Require Import
     Events.MapDefault.
From ExtLib Require Import
     Core.RelDec
     Structures.Maps
     Data.Map.FMapAList.

Require Import HTactics ProofMode.

Set Implicit Arguments.

Local Open Scope nat_scope.

Section SIMMODSEM.

  Context `{Σ: GRA.t}.

  Let W: Type := Any.t * Any.t.

  Let wf: _ -> W -> Prop :=
    mk_wf (fun (_: unit) _ _ => (True: iProp)%I).

  Theorem correct: refines2 [MutMain0.Main] [MutMain1.Main].
  Proof.
    eapply adequacy_local2. econs; ss.
    i. econstructor 1 with (wf:=wf) (le:=top2); et.
    { ss. }
    2: { exists tt. red. econs; ss. rr. uipropall. }
    econs; ss. init.
    unfold mainF, mainBody. harg.
    mDesAll. des; clarify. steps.
    astart 10. acatch. hcall _ tt with "*"; ss.
    { iPureIntro. esplits; eauto.
      { instantiate (1:=10). ss. }
      { unfold mut_max. lia. }
    }
    steps. astop. mDesAll. des; clarify. steps.
    hret tt; ss.
    Unshelve. all: ss. all: try exact 0.
  Qed.

End SIMMODSEM.


Require Import include_frm.
Require Import math_rewrite.
Require Import int_auto.

Local Open Scope int_scope.
Local Open Scope Z_scope.

(* the following lemmas if for strut_type_vallist_match tactic *)
Lemma isptr_is_definitely_ptr :
  forall x, isptr x ->  match x with
   | Vundef => false
   | Vnull => true
   | Vint32 _ => false
   | Vptr _ => true
   end = true.
Proof.
  intros.
  destruct x;
  destruct H;
  simpljoin;
  tryfalse.
Qed.

Lemma le255_and_le255 :
  forall x v'37,
    Int.unsigned x<=255 -> Int.unsigned (x &ᵢ v'37) <= 255.
Proof.
  intros.
  set (Int.and_le x v'37).
  omega.
Qed.

Lemma ptr_isptr : forall x, isptr (Vptr x).
  intros.
  unfolds.
  right; eexists; eauto.
Qed.

Lemma Vnull_is_ptr : isptr Vnull.
Proof.
  unfolds; auto.
Qed.

Hint Resolve le255_and_le255                    : struct_type_match_side_lib.
Hint Resolve ptr_isptr                          : struct_type_match_side_lib.
Hint Resolve Vnull_is_ptr                       : struct_type_match_side_lib.
Hint Resolve isptr_is_definitely_ptr            : struct_type_match_side_lib.

Ltac struct_single_condition_solver :=
  let H := fresh in
  try math_simpl H;
    try solve [ auto with struct_type_match_side_lib
                            (* here just bsimpl*r* just to compat with old version *)
               |math prove neg H; bsimplr; auto with struct_type_match_side_lib; omega].

Ltac struct_type_match_solver_new :=
  match goal with
    | |- struct_type_vallist_match ?a _ => unfold a
  end;
  unfold struct_type_vallist_match; simpl; repeat splits ; struct_single_condition_solver.

Ltac struct_type_match_solver := struct_type_match_solver_new.

(* Require Import os_ucos_h.
 *
 * Lemma struct_type_vallist_match_os_tcb :
 *   forall xx v'82 v'80 v'37 v'75 v'76 v'77 v'78 v'79 xxx yyy flag,
 *     isptr xxx ->
 *     isptr yyy ->
 *     isptr v'82 ->
 *     isptr v'80 ->
 *     Int.unsigned v'37 <= 255 ->
 *     Int.unsigned v'75 <= 255 ->
 *     Int.unsigned v'76 <= 255 ->
 *     Int.unsigned v'77 <= 255 ->
 *     Int.unsigned v'78 <= 255 ->
 *     Int.unsigned v'79 <= 255 ->
 *     Int.unsigned xx <= 65535->
 *     Int.unsigned flag <= 255 ->
 *     struct_type_vallist_match OS_TCB
 *                               (v'82
 *                                  :: v'80
 *                                  :: xxx
 *                                  :: yyy
 *                                  :: Vint32 xx
 *                                  :: Vint32 (v'37 &ᵢ v'75)
 *                                  :: Vint32 v'75
 *                                  :: Vint32 v'76
 *                                  :: Vint32 v'77
 *                                  :: Vint32 v'78 :: Vint32 v'79 :: Vint32 flag::  nil).
 * Proof.
 *   intros.
 *   struct_type_match_solver_new.
 * Qed. *)

(* Lemma struct_type_vallist_match_os_event_mbox:  forall v'51 v'52 v'49 v'50 v'55, isptr v'50 -> isptr v'51 -> Int.unsigned v'52 <= 255 -> Int.unsigned v'49 <= 65535-> struct_type_vallist_match OS_EVENT (V$OS_EVENT_TYPE_MBOX
 *       :: Vint32 v'52 :: Vint32 v'49 :: v'50 :: v'55 :: v'51 :: nil).
 *   intros.
 *   pauto.
 * Qed. *)

(* Lemma struct_type_vallist_match_os_event:  forall v'51 v'52 v'49 v'50 v'55 xx, isptr v'50 -> isptr v'51 ->Int.unsigned xx <=255 -> Int.unsigned v'52 <= 255 -> Int.unsigned v'49 <= 65535-> struct_type_vallist_match OS_EVENT (Vint32 xx
 *       :: Vint32 v'52 :: Vint32 v'49 :: v'50 :: v'55 :: v'51 :: nil).
 * Proof.
 *   intros.
 *   struct_type_match_solver_new.
 * Qed. *)

(* Ltac const_le_solver := match goal with
 * | |- Int.unsigned  ($ ?e ) <= _ => try solve [clear; unfold e; int auto]
 * end.
 *
 * Ltac struct_type_match_solver := match goal with
 * | |- struct_type_vallist_match OS_EVENT _ =>  apply  struct_type_vallist_match_os_event
 * | |- struct_type_vallist_match OS_TCB _   =>  apply  struct_type_vallist_match_os_tcb
 * end; try solve [ auto 3 with struct_type_match_side_lib | unfolds; auto 3 with struct_type_match_side_lib | const_le_solver]. *)


(** * Properties about Context Free Grammars *)
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Fiat.Parsers.StringLike.Core Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Coq.Classes.RelationClasses.
Require Import Fiat.Common Fiat.Common.UIP.
Require Import Fiat.Parsers.ContextFreeGrammar.Properties Fiat.Parsers.ContextFreeGrammar.Transfer.

Set Implicit Arguments.

Local Open Scope list_scope.

Section cfg.
  Context {Char} {HSLM1 HSLM2 : StringLikeMin Char}
          {HSL1 : @StringLike Char HSLM1}
          {HSL2 : @StringLike Char HSLM2}
          {G : grammar Char}
          {R : @String Char HSLM1 -> @String Char HSLM2 -> Prop}
          {TR : transfer_respectful R}.
  Context {P : String.string -> Type}.

  Definition transfer_forall_parse_of_item'
        (transfer_forall_parse_of
         : forall str1 str2 it (HR : R str1 str2) p,
             @Forall_parse_of Char _ _ G (fun _ => P) str1 it p
             -> @Forall_parse_of Char _ _ G (fun _ => P) str2 it (transfer_parse_of HR p))
        {str1 str2 it}
        (HR : R str1 str2)
        {p}
  : @Forall_parse_of_item' Char _ HSL1 G (fun _ => P) (@Forall_parse_of _ _ _ _ (fun _ => P)) str1 it p
    -> @Forall_parse_of_item' Char _ HSL2 G (fun _ => P) (@Forall_parse_of _ _ _ _ (fun _ => P)) str2 it (transfer_parse_of_item HR p)
    := match
        p in (parse_of_item _ _ it)
        return
        (@Forall_parse_of_item' Char _ HSL1 G (fun _ => P) (@Forall_parse_of _ _ _ _ (fun _ => P)) str1 it p
         -> @Forall_parse_of_item' Char _ HSL2 G (fun _ => P) (@Forall_parse_of _ _ _ _ (fun _ => P)) str2 it (transfer_parse_of_item HR p))
      with
        | ParseTerminal _ _ _ _ => fun x => x
        | ParseNonTerminal _ H' p' => fun xy => (fst xy, transfer_forall_parse_of _ _ _ _ p' (snd xy))
      end.

  Fixpoint transfer_forall_parse_of
           str1 str2 pats
           (HR : R str1 str2)
           {p}
           {struct p}
  : @Forall_parse_of Char _ HSL1 G (fun _ => P) str1 pats p
    -> @Forall_parse_of Char _ HSL2 G (fun _ => P) str2 pats (transfer_parse_of HR p)
    := match
        p in (parse_of _ _ pats)
        return
        (@Forall_parse_of Char _ HSL1 G (fun _ => P) str1 pats p
         -> @Forall_parse_of Char _ HSL2 G (fun _ => P) str2 pats (transfer_parse_of HR p))
      with
        | ParseHead _ _ p' => @transfer_forall_parse_of_production _ _ _ _ p'
        | ParseTail _ _ p' => @transfer_forall_parse_of _ _ _ _ p'
      end
  with transfer_forall_parse_of_production
         str1 str2 pat
         (HR : R str1 str2)
         {p}
         {struct p}
       : @Forall_parse_of_production Char _ HSL1 G (fun _ => P) str1 pat p
         -> @Forall_parse_of_production Char _ HSL2 G (fun _ => P) str2 pat (transfer_parse_of_production HR p)
       := match
           p in (parse_of_production _ _ pat)
           return
           (@Forall_parse_of_production Char _ HSL1 G (fun _ => P) str1 pat p
            -> @Forall_parse_of_production Char _ HSL2 G (fun _ => P) str2 pat (transfer_parse_of_production HR p))
         with
           | ParseProductionNil _ => fun x => x
           | ParseProductionCons _ _ _ p0 p1
             => fun xy
                => (@transfer_forall_parse_of_item' (@transfer_forall_parse_of) _ _ _ _ p0 (fst xy),
                    @transfer_forall_parse_of_production _ _ _ _ p1 (snd xy))
         end.

  Global Arguments transfer_forall_parse_of {_ _ _} HR {_} _.
  Global Arguments transfer_forall_parse_of_production {_ _ _} HR {_} _.

  Definition transfer_forall_parse_of_item
             {str1 str2 it}
             (HR : R str1 str2)
             {p}
  : @Forall_parse_of_item Char _ HSL1 G (fun _ => P) str1 it p
    -> @Forall_parse_of_item Char _ HSL2 G (fun _ => P) str2 it (transfer_parse_of_item HR p)
    := @transfer_forall_parse_of_item' (@transfer_forall_parse_of) str1 str2 it HR p.
End cfg.


From mathcomp Require Import ssreflect.
From stdpp Require Import gmap.
From iris.algebra Require Import agree auth gset gmap.
From iris.base_logic.lib Require Import invariants.
From iris.heap_lang Require Import notation proofmode.
From iris.proofmode Require Import base environments.
From cryptis Require Import lib term cryptis primitives.
Import bi.
Import env_notations.

Section Proofs.

Context `{!heapG Σ, !cryptisG Σ}.

Implicit Types E : coPset.
Implicit Types l : loc.
Implicit Types t : term.
Implicit Types v : val.
Implicit Types Φ : prodO locO termO -n> iPropO Σ.
Implicit Types Ψ : val → iProp Σ.

Lemma tac_wp_cons `{!Repr A} Γ E K (x : A) (xs : list A) Ψ :
  envs_entails Γ (WP fill K (Val (repr (x :: xs)%list)) @ E {{ Ψ }}) →
  envs_entails Γ (WP fill K (repr x :: repr xs) @ E {{ Ψ }}).
Proof.
rewrite envs_entails_eq => post.
by rewrite -wp_bind -wp_cons.
Qed.

Lemma tac_wp_cons1 `{!Repr A} Γ E K (x : A) Ψ :
  envs_entails Γ (WP fill K (Val (repr [x]%list)) @ E {{ Ψ }}) →
  envs_entails Γ (WP fill K (repr x :: []%V) @ E {{ Ψ }}).
Proof.
rewrite (_ : NILV = repr (@nil A)) /=; first by apply: tac_wp_cons.
by rewrite repr_list_eq /=.
Qed.

Lemma tac_wp_list_match `{!Repr A} Γ E K vars vs k Ψ :
  nforall_eq (length vars) vs (
    λ vs', envs_entails Γ (WP fill K (nsubst vars (map repr vs') k) @ E {{ Ψ }})) →
  (length vars ≠ length vs →
    envs_entails Γ (WP fill K NONEV @ E {{ Ψ }})) →
  envs_entails Γ (WP fill K (list_match vars (repr vs) k) @ E {{ Ψ }}).
Proof.
rewrite envs_entails_eq => /nforallP hyes hno.
rewrite -wp_bind -wp_list_match.
case: decide => [e_len|ne_len]; last by iApply hno.
by rewrite -wp_bind_inv; iApply hyes.
Qed.

Lemma tac_wp_hash Γ E K t Ψ :
  envs_entails Γ (WP fill K (Val (THash t)) @ E {{ Ψ }}) →
  envs_entails Γ (WP fill K (hash t) @ E {{ Ψ }}).
Proof.
rewrite envs_entails_eq => post.
by rewrite -wp_bind -wp_hash.
Qed.

Lemma tac_wp_tag Γ E K N t Ψ :
  envs_entails Γ (WP fill K (Val (Spec.tag N t)) @ E {{ Ψ }}) →
  envs_entails Γ (WP fill K (tag N t) @ E {{ Ψ }}).
Proof.
rewrite envs_entails_eq => ?.
by rewrite -wp_bind -wp_tag.
Qed.

Lemma tac_twp_untag Γ E K n t Ψ :
  (∀ t', t = Spec.tag n t' →
         envs_entails Γ (WP fill K (Val (repr (Some t'))) @ E [{ Ψ }])) →
  (Spec.untag n t = None →
   envs_entails Γ (WP fill K (Val NONEV) @ E [{ Ψ }])) →
  envs_entails Γ (WP fill K (untag n t) @ E [{ Ψ }]).
Proof.
rewrite envs_entails_eq => HSome HNone.
rewrite -twp_bind -twp_untag.
case e: Spec.untag => [t'|].
- by move/Spec.untagK in e; apply: HSome.
- exact: HNone.
Qed.

Lemma tac_wp_untag Γ E K n t Ψ :
  (∀ t', t = Spec.tag n t' →
         envs_entails Γ (WP fill K (Val (repr (Some t'))) @ E {{ Ψ }})) →
  (Spec.untag n t = None →
   envs_entails Γ (WP fill K (Val NONEV) @ E {{ Ψ }})) →
  envs_entails Γ (WP fill K (untag n t) @ E {{ Ψ }}).
Proof.
rewrite envs_entails_eq => HSome HNone.
rewrite -wp_bind -wp_untag.
case e: Spec.untag => [t'|].
- by move/Spec.untagK in e; apply: HSome.
- exact: HNone.
Qed.

Lemma tac_twp_dec Γ E K k t Ψ :
  (∀ t', t = TEnc k t' →
         envs_entails Γ (WP fill K (Val (SOMEV t')) @ E [{ Ψ }])) →
  (Spec.dec (TKey Dec k) t = None →
   envs_entails Γ (WP fill K (Val NONEV) @ E [{ Ψ }])) →
  envs_entails Γ (WP fill K (dec (TKey Dec k) t) @ E [{ Ψ }]).
Proof.
rewrite envs_entails_eq => HSome HNone.
rewrite -twp_bind -twp_dec.
case: t HSome HNone; eauto => k' /=.
by case: decide => [<-|]; eauto.
Qed.

Lemma tac_wp_dec Γ E K k t Ψ :
  (∀ t', t = TEnc k t' →
         envs_entails Γ (WP fill K (Val (SOMEV t')) @ E {{ Ψ }})) →
  (Spec.dec (TKey Dec k) t = None →
   envs_entails Γ (WP fill K (Val NONEV) @ E {{ Ψ }})) →
  envs_entails Γ (WP fill K (dec (TKey Dec k) t) @ E {{ Ψ }}).
Proof.
rewrite envs_entails_eq => HSome HNone.
rewrite -wp_bind -wp_dec.
case: t HSome HNone; eauto => k' /=.
by case: decide => [<-|]; eauto.
Qed.

Lemma tac_wp_tenc Γ E K c t1 t2 Ψ :
  envs_entails Γ (WP fill K (Val (Spec.tenc c t1 t2)) @ E {{ Ψ }}) →
  envs_entails Γ (WP fill K (tenc c t1 t2) @ E {{ Ψ }}).
Proof.
rewrite envs_entails_eq => H.
by rewrite -wp_bind -wp_tenc.
Qed.

(* MOVE *)
Lemma tdecK c k t t' :
  Spec.tdec c (TKey Dec k) t = Some t' →
  t = TEnc k (Spec.tag c t').
Proof.
rewrite /Spec.tdec /=.
case: t => [] //= k' t.
by case: decide => //= <- /Spec.untagK ->.
Qed.
(* /MOVE *)

Lemma tac_wp_tdec Γ E K c k t Ψ :
  (∀ t', t = TEnc k (Spec.tag c t') →
         envs_entails Γ (WP fill K (Val (SOMEV t')) @ E {{ Ψ }})) →
  (Spec.tdec c (TKey Dec k) t = None →
   envs_entails Γ (WP fill K (Val NONEV) @ E {{ Ψ }})) →
  envs_entails Γ (WP fill K (tdec c (TKey Dec k) t) @ E {{ Ψ }}).
Proof.
rewrite envs_entails_eq => HSome HNone.
rewrite -wp_bind -wp_tdec.
case e: Spec.tdec => [t'|]; eauto.
by apply: HSome; apply: tdecK.
Qed.

Lemma tac_wp_list Γ E K (ts : list term) Ψ :
  envs_entails Γ (WP fill K (Val (repr ts)) @ E {{ Ψ }}) →
  envs_entails Γ (WP fill K (list_to_expr ts) @ E {{ Ψ }}).
Proof.
rewrite envs_entails_eq => post.
by rewrite -wp_bind -wp_list.
Qed.

Lemma tac_twp_list_of_term Γ E K t Ψ :
  (∀ ts, t = Spec.of_list ts →
         envs_entails Γ (WP fill K (Val (SOMEV (repr ts))) @ E [{ Ψ }])) →
  (Spec.to_list t = None →
   envs_entails Γ (WP fill K NONEV @ E [{ Ψ }])) →
  envs_entails Γ (WP fill K (list_of_term t) @ E [{ Ψ }]).
Proof.
rewrite envs_entails_eq => HSome HNone.
rewrite -twp_bind -twp_list_of_term.
case e: Spec.to_list => [ts|]; eauto.
move/Spec.to_listK in e; subst t; eauto.
Qed.

Lemma tac_wp_list_of_term Γ E K t Ψ :
  (∀ ts, t = Spec.of_list ts →
         envs_entails Γ (WP fill K (Val (SOMEV (repr ts))) @ E {{ Ψ }})) →
  (Spec.to_list t = None →
   envs_entails Γ (WP fill K NONEV @ E {{ Ψ }})) →
  envs_entails Γ (WP fill K (list_of_term t) @ E {{ Ψ }}).
Proof.
rewrite envs_entails_eq => HSome HNone.
rewrite -wp_bind -wp_list_of_term.
case e: Spec.to_list => [ts|]; eauto.
move/Spec.to_listK in e; subst t; eauto.
Qed.

(* TODO:
- Generalize to other instances of Repr
- rename get_list -> lookup *)
Lemma tac_twp_lookup Γ E K ts (n : Z) Ψ :
  (0 <= n)%Z →
  (∀ t, (ts !! Z.to_nat n)%stdpp = Some t →
        envs_entails Γ (WP fill K (Val (SOMEV t)) @ E [{ Ψ }])) →
  ((ts !! Z.to_nat n)%stdpp = None →
   envs_entails Γ (WP fill K (Val NONEV) @ E [{ Ψ }])) →
  envs_entails Γ (WP fill K (repr ts !! #n)%E @ E [{ Ψ }]).
Proof.
move=> npos; rewrite -[in #n](Z2Nat.id n) //.
move: (Z.to_nat _)=> {npos} n.
rewrite envs_entails_eq => HSome HNone.
rewrite -twp_bind -twp_get_list.
by case e: (_ !! n)%stdpp => [t|]; eauto.
Qed.

Lemma tac_wp_lookup Γ E K ts (n : Z) Ψ :
  (0 <= n)%Z →
  (∀ t, (ts !! Z.to_nat n)%stdpp = Some t →
        envs_entails Γ (WP fill K (Val (SOMEV t)) @ E {{ Ψ }})) →
  ((ts !! Z.to_nat n)%stdpp = None →
   envs_entails Γ (WP fill K (Val NONEV) @ E {{ Ψ }})) →
  envs_entails Γ (WP fill K (repr ts !! #n)%E @ E {{ Ψ }}).
Proof.
move=> npos; rewrite -[in #n](Z2Nat.id n) //.
move: (Z.to_nat _)=> {npos} n.
rewrite envs_entails_eq => HSome HNone.
rewrite -wp_bind -wp_get_list.
by case e: (_ !! n)%stdpp => [t|]; eauto.
Qed.

Lemma tac_wp_eq_term Γ E K t1 t2 Ψ :
  (t1 = t2 →
   envs_entails Γ (WP fill K (Val #true) @ E {{ Ψ }})) →
  (t1 ≠ t2 →
   envs_entails Γ (WP fill K (Val #false) @ E {{ Ψ }})) →
  envs_entails Γ (WP fill K (eq_term t1 t2) @ E {{ Ψ }}).
Proof.
rewrite envs_entails_eq => HSome HNone.
rewrite -wp_bind -wp_eq_term.
by case: bool_decide_reflect; eauto.
Qed.

Lemma tac_wp_is_key Γ E K t Ψ :
  (∀ kt k, t = TKey kt k →
           envs_entails Γ (WP fill K (Val (SOMEV (repr kt))) @ E {{ Ψ }})) →
  (Spec.is_key t = None →
   envs_entails Γ (WP fill K (Val NONEV) @ E {{ Ψ }})) →
  envs_entails Γ (WP fill K (is_key t) @ E {{ Ψ }}).
Proof.
rewrite envs_entails_eq => HSome HNone.
rewrite -wp_bind -wp_is_key.
case: t HSome HNone; eauto.
by move=> kt k HSome _ /=; eapply HSome.
Qed.

End Proofs.

Tactic Notation "wp_cons" :=
  wp_pures;
  lazymatch goal with
  | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
    reshape_expr e ltac:(fun K e' =>
      lazymatch e' with
      | App (App (Val CONS) (Val (?f ?x))) (Val ?e'') =>
        lazymatch e'' with
        | InjLV (LitV LitUnit) =>
          let A := type of x in
          first
            [eapply (@tac_wp_cons1 _ _ A _ _ _ K x _); wp_finish
            |fail 1 "wp_cons: Cannot decode"]
        | _ =>
          first
            [eapply (tac_wp_cons _ _ K x _ _); wp_finish
            |fail 1 "wp_cons: Cannot decode"]
        end
      end)
  end.

Tactic Notation "wp_list" := repeat wp_cons.

Tactic Notation "wp_list_match" :=
  wp_pures;
  do ?[rewrite subst_list_match /=];
  lazymatch goal with
  | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
    reshape_expr e ltac:(fun K e' =>
      lazymatch e' with
      | list_match ?vars (Val (?f ?xs)) ?k =>
        lazymatch type of xs with
        | list ?A =>
          first
            [eapply (@tac_wp_list_match _ _ A _ _ E K vars xs k); simpl
            |fail 1 "wp_list_match: Cannot decode"]
        end
      end)
  end.

Tactic Notation "wp_term_of_list" :=
  wp_pures; try wp_bind (term_of_list _); iApply wp_term_of_list.

Tactic Notation "wp_enc" :=
  wp_pures; try wp_bind (enc _ _); iApply wp_enc.

Tactic Notation "wp_tenc" :=
  wp_pures; try wp_bind (tenc _ _ _); iApply wp_tenc.

Tactic Notation "wp_hash" :=
  wp_pures;
  lazymatch goal with
  | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
    reshape_expr e ltac:(fun K e' =>
      first
        [eapply (tac_wp_hash _ _ K _ _); wp_finish
        |fail 1 "wp_hash: Cannot decode"])
  end.

Tactic Notation "wp_dec_eq" ident(t) ident(H) :=
  wp_pures;
  lazymatch goal with
  | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
    reshape_expr e ltac:(fun K e' =>
      first
        [eapply (tac_wp_dec _ _ K _ _);
         [intros t H|intros H];
         wp_finish
        |fail 1 "wp_dec: Cannot decode"])
  end.

Tactic Notation "wp_dec" ident(t) :=
  let tf := fresh "tf" in
  let H := fresh "H" in
  wp_dec_eq tf H; [
    first [revert t tf H; intros _ t ->
          |revert tf H; intros _ t ->
          |revert tf H; intros t _]
  | clear H].

Tactic Notation "wp_tdec_eq" ident(t) ident(H) :=
  wp_pures;
  lazymatch goal with
  | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
    reshape_expr e ltac:(fun K e' =>
      first
        [eapply (tac_wp_tdec _ _ K _ _);
         [intros t H|intros H];
         wp_finish
        |fail 1 "wp_tdec: Cannot decode"])
  end.

Tactic Notation "wp_tdec" ident(t) :=
  let tf := fresh "tf" in
  let H := fresh "H" in
  wp_tdec_eq tf H; [
    first [revert t tf H; intros _ t ->
          |revert tf H; intros _ t ->
          |revert tf H; intros t _]
  | clear H].

Tactic Notation "wp_list_of_term_eq" ident(t) ident(H) :=
  wp_pures;
  lazymatch goal with
  | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
    reshape_expr e ltac:(fun K e' =>
      first
        [eapply (tac_wp_list_of_term _ _ K _ _);
         [intros t H|intros H];
         wp_finish
        |fail 1 "wp_dec: Cannot decode"])
  end.

Tactic Notation "wp_list_of_term" ident(t) :=
  let tf := fresh "tf" in
  let H := fresh "H" in
  wp_list_of_term_eq tf H; [
    first [revert t tf H; intros _ t ->
          |revert tf H; intros _ t ->
          |revert tf H; intros t _]
  | clear H].

Tactic Notation "wp_lookup" ident(t) ident(H) :=
  wp_pures;
  lazymatch goal with
  | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
    reshape_expr e ltac:(fun K e' =>
      first
        [eapply (tac_wp_lookup _ _ K _ _);
         [lia|intros t H|intros H];
         wp_finish
        |fail 1 "wp_lookup: Cannot decode"])
  end.

Tactic Notation "wp_eq_term" ident(H) :=
  wp_pures;
  lazymatch goal with
  | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
    reshape_expr e ltac:(fun K e' =>
      first
        [eapply (tac_wp_eq_term _ _ K _ _); intros H; wp_finish
        |fail 1 "wp_eq_term: Cannot decode"])
  end.

Tactic Notation "wp_tag" :=
  wp_pures;
  lazymatch goal with
  | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
    reshape_expr e ltac:(fun K e' =>
      first
        [eapply (tac_wp_tag _ _ K _ _); wp_finish
        |fail 1 "wp_tag: Cannot decode"])
  end.

Tactic Notation "wp_untag_eq" ident(t) ident(H) :=
  wp_pures;
  lazymatch goal with
  | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
    reshape_expr e ltac:(fun K e' =>
      first
        [eapply (tac_wp_untag _ _ K _ _);
         [intros t H|intros H];
         wp_finish
        |fail 1 "wp_untag_eq: Cannot decode"])
  end.

Tactic Notation "wp_untag" ident(t) :=
  let tf := fresh "tf" in
  let H := fresh "H" in
  wp_untag_eq tf H; [
    first [revert t tf H; intros _ t ->
          |revert tf H; intros _ t ->
          |revert tf H; intros t _]
  | clear H].

Tactic Notation "wp_is_key_eq" ident(kt) ident(k) ident(H) :=
  wp_pures;
  lazymatch goal with
  | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
    reshape_expr e ltac:(fun K e' =>
      first
        [eapply (tac_wp_is_key _ _ K _ _);
         [intros kt k H|intros H];
         wp_finish
        |fail 1 "wp_untag_eq: Cannot decode"])
  end.


Require Import Ensembles.
Require Import syntax.
Require Import infrastructure.
Require Import infrastructure_props.
Require Import analysis.
Require Import typings.
Require Import static.
Require Import List.
Require Import Arith.
Require Import tactics.
Require Import monad.
Require Import events.
Require Import Metatheory.
Require Import genericvalues.
Require Import alist.
Require Import Memory.
Require Import Integers.
Require Import Coqlib.
Require Import targetdata.
Require Import AST.
Require Import Maps.
Require Import maps_ext.
Require Import opsem.
Require Import vellvm_tactics.
Require Import util.

(***********************************************************)
(* This file proves the properties of operational semantics. *)

Module OpsemProps. Section OpsemProps.

Export Opsem.

(***********************************************************)
(* Properties of sop_star *)

Lemma sop_star_trans : forall cfg state1 state2 state3 tr12 tr23,
  sop_star cfg state1 state2 tr12 ->
  sop_star cfg state2 state3 tr23 ->
  sop_star cfg state1 state3 (Eapp tr12 tr23).
Proof.
  intros cfg state1 state2 state3 tr12 tr23 Hdsop12 Hdsop23.
  generalize dependent state3.
  generalize dependent tr23.
  induction Hdsop12; intros; auto.
    rewrite Eapp_assoc. eauto.
Qed.

(***********************************************************)
(* Properties of sop_plus *)
Lemma sop_plus__implies__sop_star : forall cfg state state' tr,
  sop_plus cfg state state' tr ->
  sop_star cfg state state' tr.
Proof.
  intros cfg state state' tr Hdsop_plus.
  inversion Hdsop_plus; subst; eauto.
Qed.

Hint Resolve sop_plus__implies__sop_star.

(***********************************************************)
(* Properties of sop_diverges *)
Ltac app_inv :=
  match goal with
  | [ H: ?f _ _ _ _ _ _ = ?f _ _ _ _ _ _ |- _ ] => inv H
  | [ H: ?f _ _ _ _ _ = ?f _ _ _ _ _ |- _ ] => inv H
  | [ H: ?f _ _ = ?f _ _ |- _ ] => inv H
  end.

(***********************************************************)
(* Inversion of operations *)
Lemma BOP_inversion : forall TD lc gl b s v1 v2 gv2,
  BOP TD lc gl b s v1 v2 = Some gv2 ->
  exists gvs1, exists gvs2,
    getOperandValue TD v1 lc gl = Some gvs1 /\
    getOperandValue TD v2 lc gl = Some gvs2 /\
    (mbop TD b s) gvs1 gvs2 = Some gv2.
Proof.
  intros TD lc gl b s v1 v2 gv2 HBOP.
  unfold BOP in HBOP.
  remember (getOperandValue TD v1 lc gl) as ogv1.
  destruct ogv1; try solve [inversion HBOP].
  remember (getOperandValue TD v2 lc gl) as ogv2.
  destruct ogv2; inv HBOP.
  eauto.
Qed.

Lemma FBOP_inversion : forall TD lc gl b fp v1 v2 gv,
  FBOP TD lc gl b fp v1 v2 = Some gv ->
  exists gv1, exists gv2,
    getOperandValue TD v1 lc gl = Some gv1 /\
    getOperandValue TD v2 lc gl = Some gv2 /\
    (mfbop TD b fp) gv1 gv2 = Some gv.
Proof.
  intros TD lc gl b fp v1 v2 gv HFBOP.
  unfold FBOP in HFBOP.
  remember (getOperandValue TD v1 lc gl) as ogv1.
  destruct ogv1; try solve [inversion HFBOP].
  remember (getOperandValue TD v2 lc gl) as ogv2.
  destruct ogv2; inv HFBOP.
  eauto.
Qed.

Lemma CAST_inversion : forall TD lc gl op t1 v1 t2 gv,
  CAST TD lc gl op t1 v1 t2 = Some gv ->
  exists gv1,
    getOperandValue TD v1 lc gl = Some gv1 /\
    (mcast TD op t1 t2) gv1 = Some gv.
Proof.
  intros TD lc gl op t1 v1 t2 gv HCAST.
  unfold CAST in HCAST.
  remember (getOperandValue TD v1 lc gl) as ogv1.
  destruct ogv1; inv HCAST.
  eauto.
Qed.

Lemma TRUNC_inversion : forall TD lc gl op t1 v1 t2 gv,
  TRUNC TD lc gl op t1 v1 t2 = Some gv ->
  exists gv1,
    getOperandValue TD v1 lc gl = Some gv1 /\
    (mtrunc TD op t1 t2) gv1 = Some gv.
Proof.
  intros TD lc gl op t1 v1 t2 gv HTRUNC.
  unfold TRUNC in HTRUNC.
  remember (getOperandValue TD v1 lc gl) as ogv1.
  destruct ogv1; inv HTRUNC.
  eauto.
Qed.

Lemma EXT_inversion : forall TD lc gl op t1 v1 t2 gv,
  EXT TD lc gl op t1 v1 t2 = Some gv ->
  exists gv1,
    getOperandValue TD v1 lc gl = Some gv1 /\
    (mext TD op t1 t2) gv1 = Some gv.
Proof.
  intros TD lc gl op t1 v1 t2 gv HEXT.
  unfold EXT in HEXT.
  remember (getOperandValue TD v1 lc gl) as ogv1.
  destruct ogv1; inv HEXT.
  eauto.
Qed.

Lemma ICMP_inversion : forall TD lc gl cond t v1 v2 gv,
  ICMP TD lc gl cond t v1 v2 = Some gv ->
  exists gv1, exists gv2,
    getOperandValue TD v1 lc gl = Some gv1 /\
    getOperandValue TD v2 lc gl = Some gv2 /\
    (micmp TD cond t) gv1 gv2 = Some gv.
Proof.
  intros TD lc gl cond0 t v1 v2 gv HICMP.
  unfold ICMP in HICMP.
  remember (getOperandValue TD v1 lc gl) as ogv1.
  destruct ogv1; try solve [inversion HICMP].
  remember (getOperandValue TD v2 lc gl) as ogv2.
  destruct ogv2; inv HICMP.
  eauto.
Qed.

Lemma FCMP_inversion : forall TD lc gl cond fp v1 v2 gv,
  FCMP TD lc gl cond fp v1 v2 = Some gv ->
  exists gv1, exists gv2,
    getOperandValue TD v1 lc gl = Some gv1 /\
    getOperandValue TD v2 lc gl = Some gv2 /\
    (mfcmp TD cond fp) gv1 gv2 = Some gv.
Proof.
  intros TD lc gl cond0 fp v1 v2 gv HFCMP.
  unfold FCMP in HFCMP.
  remember (getOperandValue TD v1 lc gl) as ogv1.
  destruct ogv1; try solve [inversion HFCMP].
  remember (getOperandValue TD v2 lc gl) as ogv2.
  destruct ogv2; inv HFCMP.
  eauto.
Qed.

(***********************************************************)
(* Equivalence of operations *)
Lemma const2GV_eqAL : forall c gl1 gl2 TD,
  eqAL _ gl1 gl2 ->
  const2GV TD gl1 c = const2GV TD gl2 c.
Proof.
  intros. unfold const2GV.
  destruct const2GV_eqAL_aux.
  erewrite H0; eauto.
Qed.

Lemma getOperandValue_eqAL : forall lc1 gl lc2 v TD,
  eqAL _ lc1 lc2 ->
  getOperandValue TD v lc1 gl = getOperandValue TD v lc2 gl.
Proof.
  intros lc1 gl lc2 v TD HeqAL.
  unfold getOperandValue in *.
  destruct v; auto.
Qed.

Lemma BOP_eqAL : forall lc1 gl lc2 bop0 sz0 v1 v2 TD,
  eqAL _ lc1 lc2 ->
  BOP TD lc1 gl bop0 sz0 v1 v2 = BOP TD lc2 gl bop0 sz0 v1 v2.
Proof.
  intros lc1 gl lc2 bop0 sz0 v1 v2 TD HeqEnv.
  unfold BOP in *.
  rewrite getOperandValue_eqAL with (lc2:=lc2)(v:=v1); auto.
  rewrite getOperandValue_eqAL with (lc2:=lc2)(v:=v2); auto.
Qed.

Lemma FBOP_eqAL : forall lc1 gl lc2 fbop0 fp0 v1 v2 TD,
  eqAL _ lc1 lc2 ->
  FBOP TD lc1 gl fbop0 fp0 v1 v2 = FBOP TD lc2 gl fbop0 fp0 v1 v2.
Proof.
  intros lc1 gl lc2 fbop0 fp0 v1 v2 TD HeqEnv.
  unfold FBOP in *.
  rewrite getOperandValue_eqAL with (lc2:=lc2)(v:=v1); auto.
  rewrite getOperandValue_eqAL with (lc2:=lc2)(v:=v2); auto.
Qed.

Lemma CAST_eqAL : forall lc1 gl lc2 op t1 v1 t2 TD,
  eqAL _ lc1 lc2 ->
  CAST TD lc1 gl op t1 v1 t2 = CAST TD lc2 gl op t1 v1 t2.
Proof.
  intros lc1 gl lc2 op t1 v1 t2 TD HeqAL.
  unfold CAST in *.
  rewrite getOperandValue_eqAL with (lc2:=lc2)(v:=v1); auto.
Qed.

Lemma TRUNC_eqAL : forall lc1 gl lc2 op t1 v1 t2 TD,
  eqAL _ lc1 lc2 ->
  TRUNC TD lc1 gl op t1 v1 t2 = TRUNC TD lc2 gl op t1 v1 t2.
Proof.
  intros lc1 gl lc2 op t1 v1 t2 TD HeqAL.
  unfold TRUNC in *.
  rewrite getOperandValue_eqAL with (lc2:=lc2)(v:=v1); auto.
Qed.

Lemma EXT_eqAL : forall lc1 gl lc2 op t1 v1 t2 TD,
  eqAL _ lc1 lc2 ->
  EXT TD lc1 gl op t1 v1 t2 = EXT TD lc2 gl op t1 v1 t2.
Proof.
  intros lc1 gl lc2 op t1 v1 t2 TD HeqAL.
  unfold EXT in *.
  rewrite getOperandValue_eqAL with (lc2:=lc2)(v:=v1); auto.
Qed.

Lemma ICMP_eqAL : forall lc1 gl lc2 cond t v1 v2 TD,
  eqAL _ lc1 lc2 ->
  ICMP TD lc1 gl cond t v1 v2 = ICMP TD lc2 gl cond t v1 v2.
Proof.
  intros lc1 gl lc2 cond0 t v1 v2 TD HeqAL.
  unfold ICMP in *.
  rewrite getOperandValue_eqAL with (lc2:=lc2)(v:=v1); auto.
  rewrite getOperandValue_eqAL with (lc2:=lc2)(v:=v2); auto.
Qed.

Lemma FCMP_eqAL : forall lc1 gl lc2 cond fp v1 v2 TD,
  eqAL _ lc1 lc2 ->
  FCMP TD lc1 gl cond fp v1 v2 = FCMP TD lc2 gl cond fp v1 v2.
Proof.
  intros lc1 gl lc2 cond0 fp v1 v2 TD HeqAL.
  unfold FCMP in *.
  rewrite getOperandValue_eqAL with (lc2:=lc2)(v:=v1); auto.
  rewrite getOperandValue_eqAL with (lc2:=lc2)(v:=v2); auto.
Qed.

Lemma values2GVs_eqAL : forall l0 lc1 gl lc2 TD,
  eqAL _ lc1 lc2 ->
  values2GVs TD l0 lc1 gl = values2GVs TD l0 lc2 gl.
Proof.
  induction l0 as [|[s v] l0]; intros lc1 gl lc2 TD HeqAL; simpl; auto.
    rewrite getOperandValue_eqAL with (lc2:=lc2)(v:=v); auto.
    erewrite IHl0; eauto.
Qed.

(***********************************************************)
(* Uniqueness of operations *)
Lemma updateValuesForNewBlock_spec4 : forall rs lc id1 gv,
  lookupAL _ rs id1 = Some gv ->
  lookupAL _ (updateValuesForNewBlock rs lc) id1 = Some gv.
Proof.
  induction rs; intros; simpl in *.
    inversion H.

    destruct a.
    destruct (id1==a); subst.
      inversion H; subst. apply lookupAL_updateAddAL_eq; auto.
      rewrite <- lookupAL_updateAddAL_neq; auto.
Qed.

(***********************************************************)
(* Properties of initLocals and initializeFrameValues *)
Lemma initLocals_spec : forall TD la gvs id1 lc,
  In id1 (getArgsIDs la) ->
  initLocals TD la gvs = Some lc ->
  exists gv, lookupAL _ lc id1 = Some gv.
Proof.
  unfold initLocals.
  induction la; intros; simpl in *.
    inversion H.

    destruct a as [[t c] id0].
    simpl in H.
    destruct H as [H | H]; subst; simpl.
      destruct gvs.
        remember (_initializeFrameValues TD la nil nil) as R1.
        destruct R1; tinv H0.
        remember (gundef TD t) as R2.
        destruct R2; inv H0.
        eauto using lookupAL_updateAddAL_eq.

        remember (_initializeFrameValues TD la gvs nil) as R1.
        destruct R1; tinv H0.
        destruct ((fit_gv TD t) g); inv H0.
        eauto using lookupAL_updateAddAL_eq.

      destruct (eq_atom_dec id0 id1); subst.
        destruct gvs.
          remember (_initializeFrameValues TD la nil nil) as R1.
          destruct R1; tinv H0.
          remember (gundef TD t) as R2.
          destruct R2; inv H0.
          eauto using lookupAL_updateAddAL_eq.

          remember (_initializeFrameValues TD la gvs nil) as R1.
          destruct R1; tinv H0.
          destruct ((fit_gv TD t) g); inv H0.
          eauto using lookupAL_updateAddAL_eq.

        destruct gvs.
          remember (_initializeFrameValues TD la nil nil) as R1.
          destruct R1; tinv H0.
          remember (gundef TD t) as R2.
          destruct R2; inv H0.
          symmetry in HeqR1.
          eapply IHla in HeqR1; eauto.
          destruct HeqR1 as [gv HeqR1].
          rewrite <- lookupAL_updateAddAL_neq; eauto.

          remember (_initializeFrameValues TD la gvs nil) as R1.
          destruct R1; tinv H0.
          destruct ((fit_gv TD t) g); inv H0.
          symmetry in HeqR1.
          eapply IHla in HeqR1; eauto.
          destruct HeqR1 as [gv HeqR1].
          rewrite <- lookupAL_updateAddAL_neq; eauto.
Qed.

(***********************************************************)
(* Properties of updateValuesForNewBlock *)
Lemma updateValuesForNewBlock_spec6 : forall lc rs id1 gvs
  (Hlk : lookupAL _ (updateValuesForNewBlock rs lc) id1 = ret gvs)
  (Hin : id1 `in` (dom rs)),
  lookupAL _ rs id1 = Some gvs.
Proof.
  induction rs; simpl; intros.
    fsetdec.

    destruct a.
    assert (id1 = i0 \/ id1 `in` dom rs) as J. fsetdec.
    destruct J as [J | J]; subst.
      rewrite lookupAL_updateAddAL_eq in Hlk; auto. inv Hlk.
      destruct (@eq_dec atom (EqDec_eq_of_EqDec atom EqDec_atom) i0 i0); auto.
        contradict n; auto.

      destruct (@eq_dec atom (EqDec_eq_of_EqDec atom EqDec_atom) id1 i0);
        subst; eauto.
        rewrite lookupAL_updateAddAL_eq in Hlk; auto.
        rewrite <- lookupAL_updateAddAL_neq in Hlk; eauto.
Qed.

Lemma updateValuesForNewBlock_spec7 : forall lc rs id1 gvs
  (Hlk : lookupAL _ (updateValuesForNewBlock rs lc) id1 = ret gvs)
  (Hnotin : id1 `notin` (dom rs)),
  lookupAL _ lc id1 = ret gvs.
Proof.
  induction rs; simpl; intros; auto.
    destruct a.

    destruct_notin.
    rewrite <- lookupAL_updateAddAL_neq in Hlk; eauto.
Qed.

Lemma updateValuesForNewBlock_spec6' : forall lc rs id1
  (Hin : id1 `in` (dom rs)),
  lookupAL _ (updateValuesForNewBlock rs lc) id1 = lookupAL _ rs id1.
Proof.
  induction rs; simpl; intros.
    fsetdec.

    destruct a.
    assert (id1 = a \/ id1 `in` dom rs) as J. fsetdec.
    destruct J as [J | J]; subst.
      rewrite lookupAL_updateAddAL_eq.
      destruct (@eq_dec atom (EqDec_eq_of_EqDec atom EqDec_atom) a a); auto.
        contradict n; auto.

      destruct (@eq_dec atom (EqDec_eq_of_EqDec atom EqDec_atom) id1 a);
        subst; eauto.
        rewrite lookupAL_updateAddAL_eq; auto.
        rewrite <- lookupAL_updateAddAL_neq; eauto.
Qed.

Lemma updateValuesForNewBlock_spec7' : forall lc rs id1
  (Hin : id1 `notin` (dom rs)),
  lookupAL _ (updateValuesForNewBlock rs lc) id1 = lookupAL _ lc id1.
Proof.
  induction rs; simpl; intros; auto.
    destruct a. destruct_notin.
    rewrite <- lookupAL_updateAddAL_neq; eauto.
Qed.

Lemma updateValuesForNewBlock_spec5: forall lc1' lc2' i0
  (Hlk: lookupAL _ lc1' i0 = lookupAL _ lc2' i0) lc2
  (Hlk: merror = lookupAL _ lc2 i0),
  lookupAL _ lc1' i0 =
    lookupAL _ (Opsem.updateValuesForNewBlock lc2 lc2') i0.
Proof.
  induction lc2 as [|[]]; simpl; intros; auto.
    destruct (i0 == a); try congruence.
    rewrite <- lookupAL_updateAddAL_neq; auto.
Qed.

(***********************************************************)
(* Properties of getIncomingValuesForBlockFromPHINodes *)
Lemma getIncomingValuesForBlockFromPHINodes_spec6 : forall TD b gl lc ps' rs id1
  (HeqR1 : ret rs = getIncomingValuesForBlockFromPHINodes TD ps' b gl lc)
  (Hin : In id1 (getPhiNodesIDs ps')),
  id1 `in` dom rs.
Proof.
  induction ps'; simpl; intros.
    inv Hin.

    destruct a. destruct b. simpl in *.
    inv_mbind. inv HeqR1.
    destruct (gv_chunks_match_typb TD g typ5).
    destruct Hin as [Hin | Hin]; subst. inv H0. simpl. auto.
    inv H0. simpl. auto.
    inv H0.
Qed.

Lemma getIncomingValuesForBlockFromPHINodes_spec7 : forall TD b gl lc ps' rs id1
  (HeqR1 : ret rs = getIncomingValuesForBlockFromPHINodes TD ps' b gl lc)
  (Hin : id1 `in` dom rs),
  In id1 (getPhiNodesIDs ps').
Proof.
  induction ps'; simpl; intros.
    inv HeqR1. fsetdec.

    destruct a as [i0 ?]. destruct b as [l2 ? ? ?]. simpl in *.
    inv_mbind. inv HeqR1. simpl in *.
    assert (id1 = i0 \/ id1 `in` dom l1) as J.
    destruct (gv_chunks_match_typb TD g typ5).
    inv H0. simpl in Hin.
    fsetdec.
    inv H0.
    destruct J as [J | J]; subst; eauto.
Qed.

Lemma getIncomingValuesForBlockFromPHINodes_spec8 : forall TD b gl lc ps' rs id1
  (HeqR1 : ret rs = getIncomingValuesForBlockFromPHINodes TD ps' b gl lc)
  (Hnotin : ~ In id1 (getPhiNodesIDs ps')),
  id1 `notin` dom rs.
Proof.
  intros.
  intro J. apply Hnotin.
  eapply getIncomingValuesForBlockFromPHINodes_spec7 in HeqR1; eauto.
Qed.

Lemma getIncomingValuesForBlockFromPHINodes_spec9: forall TD gl lc b id0 gvs0
  ps' l0,
  ret l0 = Opsem.getIncomingValuesForBlockFromPHINodes TD ps' b gl lc ->
  id0 `in` dom l0 ->
  lookupAL _ l0 id0 = ret gvs0 ->
  exists id1, exists t1, exists vls1, exists v, exists n,
    In (insn_phi id1 t1 vls1) ps' /\
    nth_error vls1 n = Some (v, getBlockLabel b) /\
    Opsem.getOperandValue TD v lc gl= Some gvs0.
Proof.
  induction ps' as [|[i0 t l0]]; simpl; intros.
    inv H. fsetdec.

    inv_mbind. simpl in *.
    destruct (id0 == i0); subst.
      destruct b. simpl in *.
      symmetry in HeqR.
      apply getValueViaLabelFromValuels__nth_list_value_l in HeqR; auto.
      destruct HeqR as [n HeqR].
      destruct (@eq_dec atom (EqDec_eq_of_EqDec atom EqDec_atom) i0 i0);
        try congruence.
      destruct (gv_chunks_match_typb TD g t).
      inv H3.

      exists i0. exists t. exists l0. exists v. exists n.
      split; auto. split. auto. auto. simpl in H1.
      destruct (@eq_dec atom (EqDec_eq_of_EqDec atom EqDec_atom) i0 i0).
      inv H1. eauto. apply n0 in e. inv e.
      inv H3.
      destruct (gv_chunks_match_typb TD g t).
      inv H3. simpl in H1.
      destruct (@eq_dec atom (EqDec_eq_of_EqDec atom EqDec_atom) id0 i0).
      apply n in e. inv e.
      apply IHps' in H1; auto; try fsetdec.
      destruct H1 as [id1 [t1 [vls1 [v' [n' [J1 [J2 J3]]]]]]].
      exists id1. exists t1. exists vls1. exists v'. exists n'.
      split; auto.
      apply in_dom_cons_inv in H0.
      inv H0. assert (i0 = i0). auto. apply n in H. inv H.
      auto.
      inv H3.
Qed.

Lemma getIncomingValuesForBlockFromPHINodes_spec9': forall TD gl lc b id0 gvs0
  ps' l0,
  ret l0 = Opsem.getIncomingValuesForBlockFromPHINodes TD ps' b gl lc ->
  id0 `in` dom l0 ->
  lookupAL _ l0 id0 = ret gvs0 ->
  exists t1, exists vls1, exists v,
    In (insn_phi id0 t1 vls1) ps' /\
    getValueViaLabelFromValuels vls1 (getBlockLabel b) = Some v /\
    Opsem.getOperandValue TD v lc gl= Some gvs0.
Proof.
  induction ps' as [|[i0 t l0]]; simpl; intros.
    inv H. fsetdec.

    inv_mbind. simpl in *.
    destruct (id0 == i0); subst.
      destruct b. simpl in *.
      symmetry in HeqR.
      inv H1.
      destruct (gv_chunks_match_typb TD g t).
      inv H3.
      exists t. exists l0. exists v.
      simpl in H2.
      inv H2. split; auto. split. auto. simpl.
      destruct (@eq_dec atom (EqDec_eq_of_EqDec atom EqDec_atom) i0 i0).
      auto. assert (i0 = i0). auto. apply n in H. inv H.
      inv H3.

      destruct (gv_chunks_match_typb TD g t).
      inv H3. simpl in H1.
      destruct (@eq_dec atom (EqDec_eq_of_EqDec atom EqDec_atom) id0 i0).
      apply n in e. inv e.

      apply IHps' in H1; auto; try fsetdec.
      destruct H1 as [t1 [vls1 [v' [J1 [J2 J3]]]]].
      exists t1. exists vls1. exists v'.
      split; auto.
      apply in_dom_cons_inv in H0.
      inv H0. assert (i0 = i0). auto. apply n in H. inv H.
      auto.
      inv H3.
Qed.

End OpsemProps. End OpsemProps.


(*
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

Require Import String.
Require Import List.
Require Import Arith.
Require Import Program.
Require Import EquivDec.
Require Import Morphisms.
Require Import Utils.
Require Import DataSystem.
Require Import OQL.

Section TOQL.
  (** Typing for CAMP *)

  Section typ.

    Context {m:basic_model}.
    Section constt.
      Context (τconstants:tbindings).

      Hint Resolve bindings_type_has_type : qcert.

      Inductive oql_expr_type : tbindings -> oql_expr -> rtype -> Prop :=
      | OTConst {τ} tenv c :
          data_type (normalize_data brand_relation_brands c) τ ->
          oql_expr_type tenv (OConst c) τ
      | OTVar {τ} tenv v :
          edot tenv v = Some τ -> oql_expr_type tenv (OVar v) τ
      | OTTable {τ} tenv s :
          tdot τconstants s = Some τ ->
          oql_expr_type tenv (OTable s) τ
      | OTBinop {τ₁ τ₂ τout} tenv b e₁ e₂ :
          oql_expr_type tenv e₁ τ₁ ->
          oql_expr_type tenv e₂ τ₂ ->
          binary_op_type b τ₁ τ₂ τout ->
          oql_expr_type tenv (OBinop b e₁ e₂) τout
      | OTUnop {τ₁ τout} tenv u e₁ :
          oql_expr_type tenv e₁ τ₁ ->
          unary_op_type u τ₁ τout ->
          oql_expr_type tenv (OUnop u e₁) τout.

    End constt.

    Context (τconstants:tbindings).

    Inductive oql_query_program_type : tbindings -> tbindings -> oql_query_program -> rtype -> Prop :=
    | OTDefineQuery {tenv s e rest τ}  {tdefls τ₁} :
        oql_expr_type (rec_concat_sort τconstants tdefls) tenv e τ₁ ->
        oql_query_program_type (rec_concat_sort tdefls ((s,τ₁)::nil)) tenv rest τ ->
        oql_query_program_type tdefls tenv (ODefineQuery s e rest) τ
    | OTUndefineQuery {tenv s rest tdefls τ} :
        oql_query_program_type (rremove tdefls s) tenv rest τ ->
        oql_query_program_type tdefls tenv (OUndefineQuery s rest) τ
    |OTQuery {tdefls tenv e τ}:
     oql_expr_type (rec_concat_sort τconstants tdefls) tenv e τ ->
     oql_query_program_type tdefls tenv (OQuery e) τ.

    Definition oql_type (o:oql_query_program) (τ:rtype) : Prop
      := oql_query_program_type nil nil o τ.

    End typ.

  Theorem typed_oql_expr_yields_typed_data {m:basic_model} {τc} {τenv τout} c (env:list (string*data)) (q:oql_expr):
    bindings_type c τc ->
    bindings_type env τenv ->
    (oql_expr_type τc τenv q τout) ->
    (exists x, (oql_expr_interp brand_relation_brands c q env = Some x /\ (x ▹ τout))).
  Proof.
    intros.
    revert c env H H0.
    dependent induction H1; simpl; intros.
    - exists (normalize_data brand_relation_brands c).
      split; [reflexivity|assumption].
    - unfold bindings_type in H1.
      apply (Forall2_lookupr_some H1).
      assumption.
    - unfold bindings_type in H0.
      apply (Forall2_lookupr_some H0).
      assumption.
    - elim (IHoql_expr_type1 _ _ H0 H1); intros.
      elim (IHoql_expr_type2 _ _ H0 H1); intros.
      elim H2; clear H2; intros.
      elim H3; clear H3; intros.
      rewrite H2; rewrite H3; simpl.
      destruct (typed_binary_op_yields_typed_data _ _ _ H4 H5 H) as [?[??]].
      rewrite H6.
      exists x1; auto.
    - elim (IHoql_expr_type _ _ H0 H2); intros.
      elim H3; clear H3; intros.
      rewrite H3; simpl.
      destruct (typed_unary_op_yields_typed_data _ _ H4 H) as [?[??]].
      rewrite H5.
      exists x0; auto.
  Qed.

  Lemma typed_oql_query_program_yields_typed_data {m:basic_model} {τc τdefls} {τenv τout} c (defls env:list (string*data)) (q:oql_query_program):
    bindings_type c τc ->
    bindings_type defls τdefls ->
    bindings_type env τenv ->
    (oql_query_program_type τc τdefls τenv q τout) ->
    (exists x, (oql_query_program_interp brand_relation_brands c defls q env = Some x /\ (x ▹ τout))).
  Proof.
    intros.
    revert c defls env H H0 H1.
    dependent induction H2; simpl; intros.
    - assert (bt: bindings_type (rec_concat_sort c defls) (rec_concat_sort τc tdefls))
        by (apply bindings_type_rec_concat_sort; trivial).
      destruct (typed_oql_expr_yields_typed_data _ _ e bt H3 H)
        as [d [de dt]].
      rewrite de; simpl.
      destruct (IHoql_query_program_type _ (rec_concat_sort defls ((s,d)::nil)) env H0);
        eauto 2.
      apply bindings_type_rec_concat_sort; trivial.
      constructor; simpl; auto.
    - destruct (IHoql_query_program_type c (rremove defls s) env); eauto 2.
      apply rremove_well_typed.
      trivial.
    - eapply typed_oql_expr_yields_typed_data; eauto.
      apply bindings_type_rec_concat_sort; trivial.
  Qed.

    (** Main typing soundness theorem for OQL *)

  Theorem typed_oql_yields_typed_data {m:basic_model} {τc} {τout} c (q:oql_query_program):
    bindings_type c τc ->
    oql_type τc q τout ->
    (exists x, (oql_interp brand_relation_brands c q = Some x /\ (x ▹ τout))).
  Proof.
    intros.
    eapply typed_oql_query_program_yields_typed_data; eauto
    ; constructor.
  Qed.

End TOQL.


Require Import Raft.
Require Import RaftRefinementInterface.

Require Import CommonTheorems.

Require Import UpdateLemmas.
Local Arguments update {_} {_} {_} _ _ _ _ : simpl never.

Require Import CroniesTermInterface.

Section CroniesTermProof.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Context {rri : raft_refinement_interface}.

  Ltac update_destruct :=
    match goal with
      | [ |- context [ update _ ?y _ ?x ] ] => destruct (@name_eq_dec _ _ y x)
    end.

  Lemma handleClientRequest_spec :
    forall h st client id c out st' l,
      handleClientRequest h st client id c = (out, st', l) ->
      currentTerm st' = currentTerm st.
  Proof using.
    intros. unfold handleClientRequest in *.
    break_match; find_inversion; intuition.
  Qed.

  Lemma cronies_term_client_request :
    refined_raft_net_invariant_client_request cronies_term.
  Proof using.
    unfold refined_raft_net_invariant_client_request, cronies_term,
    update_elections_data_client_request in *.
    intros. subst. simpl in *. repeat find_higher_order_rewrite.
    update_destruct; subst; rewrite_update; eauto.
    simpl in *. find_apply_lem_hyp handleClientRequest_spec.
    repeat find_rewrite.
    repeat break_match; simpl in *; eauto.
  Qed.
  (*   H : handleTimeout h' (snd (nwState net h')) = (out, d, l)
       In h0 (cronies (update_elections_data_timeout h' (nwState net h')) t)
   *)

  Lemma handleTimeout_spec :
    forall h st out st' l t h',
      handleTimeout h (snd st) = (out, st', l) ->
      In h' (cronies (update_elections_data_timeout h st) t) ->
      (currentTerm (snd st) <= currentTerm st' /\
       (In h' (cronies (fst st) t) \/
        t = currentTerm st')).
  Proof using.
    intros.
    unfold handleTimeout, tryToBecomeLeader, update_elections_data_timeout in *.
    repeat (break_match; repeat find_inversion; simpl in *; auto);
      intuition;
      unfold handleTimeout, tryToBecomeLeader in *;
      repeat (break_match; repeat find_inversion; simpl in *; auto); congruence.
  Qed.

  Lemma cronies_term_timeout :
    refined_raft_net_invariant_timeout cronies_term.
  Proof using.
    unfold refined_raft_net_invariant_timeout, cronies_term.
    intros. subst. simpl in *. repeat find_higher_order_rewrite.
    update_destruct; subst; rewrite_update; eauto.
    simpl in *.
    find_eapply_lem_hyp handleTimeout_spec; eauto. intuition.
    eapply le_trans; [|eauto]; eauto.
  Qed.

  Lemma doLeader_spec :
    forall st h os st' ms,
      doLeader st h = (os, st', ms) ->
      currentTerm st' = currentTerm st.
  Proof using.
    intros. unfold doLeader in *.
    repeat break_match; repeat find_inversion; auto.
  Qed.

  Lemma cronies_term_do_leader :
    refined_raft_net_invariant_do_leader cronies_term.
  Proof using.
    unfold refined_raft_net_invariant_do_leader, cronies_term.
    intros. subst. simpl in *. repeat find_higher_order_rewrite.
    update_destruct; subst; rewrite_update; eauto.
    simpl in *.
    find_apply_lem_hyp doLeader_spec.
    repeat find_rewrite.
    match goal with
      | H : nwState ?net ?h = (?g, ?st) |- _ =>
        replace g with (fst (nwState net h)) in *; [|rewrite H; auto];
        replace st with (snd (nwState net h)) in *; [|rewrite H; auto]
    end; eauto.
  Qed.

  Lemma doGenericServer_spec :
    forall st h os st' ms,
      doGenericServer h st = (os, st', ms) ->
      currentTerm st' = currentTerm st.
  Proof using.
    intros. unfold doGenericServer in *.
    repeat break_match; repeat find_inversion;
    use_applyEntries_spec; subst; simpl in *;
    auto.
  Qed.

  Lemma cronies_term_do_generic_server :
    refined_raft_net_invariant_do_generic_server cronies_term.
  Proof using.
    unfold refined_raft_net_invariant_do_generic_server, cronies_term.
    intros. subst. simpl in *. repeat find_higher_order_rewrite.
    update_destruct; subst; rewrite_update; eauto.
    simpl in *.
    find_apply_lem_hyp doGenericServer_spec.
    repeat find_rewrite.
    match goal with
      | H : nwState ?net ?h = (?g, ?st) |- _ =>
        replace g with (fst (nwState net h)) in *; [|rewrite H; auto];
        replace st with (snd (nwState net h)) in *; [|rewrite H; auto]
    end; eauto.
  Qed.

  Lemma handleAppendEntries_spec :
    forall h st t n pli plt es ci st' m,
      handleAppendEntries h st t n pli plt es ci = (st', m) ->
      currentTerm st <= currentTerm st'.
  Proof using.
    intros.
    unfold handleAppendEntries, advanceCurrentTerm in *.
    repeat break_match; find_inversion; simpl in *;
    do_bool; auto.
  Qed.

  Lemma update_elections_data_appendEntries_spec :
    forall h st t n pli plt es ci st' e t',
      update_elections_data_appendEntries h st t n pli plt es ci = st' ->
      In e (cronies st' t') ->
      In e (cronies (fst st) t').
  Proof using.
    intros.
    unfold update_elections_data_appendEntries in *.
    repeat break_match; repeat find_rewrite; subst; simpl in *; auto.
  Qed.

  Lemma cronies_term_append_entries :
    refined_raft_net_invariant_append_entries cronies_term.
  Proof using.
    unfold refined_raft_net_invariant_append_entries, cronies_term.
    intros. subst. simpl in *. repeat find_higher_order_rewrite.
    update_destruct; subst; rewrite_update; eauto.
    simpl in *.
    find_apply_lem_hyp handleAppendEntries_spec.
    find_eapply_lem_hyp update_elections_data_appendEntries_spec; eauto.
    eapply le_trans; [|eauto]; eauto.
  Qed.

  Lemma handleAppendEntriesReply_spec :
    forall h st h' t es r st' ms,
      handleAppendEntriesReply h st h' t es r = (st', ms) ->
      currentTerm st <= currentTerm st'.
  Proof using.
    intros.
    unfold handleAppendEntriesReply, advanceCurrentTerm in *.
    repeat break_match; try find_inversion; subst; simpl in *;
    do_bool; intuition.
  Qed.

  Lemma cronies_term_append_entries_reply :
    refined_raft_net_invariant_append_entries_reply cronies_term.
  Proof using.
    unfold refined_raft_net_invariant_append_entries_reply, cronies_term.
    intros. subst. simpl in *. repeat find_higher_order_rewrite.
    update_destruct; subst; rewrite_update; eauto.
    simpl in *.
    find_apply_lem_hyp handleAppendEntriesReply_spec.
    eapply le_trans; [|eauto]; eauto.
  Qed.

  Lemma handleRequestVote_spec :
    forall h st t h' pli plt st' m,
      handleRequestVote h st t h' pli plt = (st', m) ->
      currentTerm st <= currentTerm st'.
  Proof using.
    intros.
    unfold handleRequestVote, advanceCurrentTerm in *.
    repeat break_match; try find_inversion; subst; simpl in *;
    do_bool; intuition.
  Qed.

  Lemma update_elections_data_requestVote_spec :
    forall h st t h' pli plt st' t' e s,
      update_elections_data_requestVote h h' t pli plt s st = st' ->
      In e (cronies st' t') ->
      In e (cronies (fst st) t').
  Proof using.
    intros.
    unfold update_elections_data_requestVote in *.
    repeat break_match; repeat find_rewrite; subst; simpl in *; auto.
  Qed.

  Lemma cronies_term_request_vote :
    refined_raft_net_invariant_request_vote cronies_term.
  Proof using.
    unfold refined_raft_net_invariant_request_vote, cronies_term.
    intros. subst. simpl in *. repeat find_higher_order_rewrite.
    update_destruct; subst; rewrite_update; eauto.
    simpl in *.
    find_apply_lem_hyp handleRequestVote_spec.
    find_eapply_lem_hyp update_elections_data_requestVote_spec; eauto.
    eapply le_trans; [|eauto]; eauto.
  Qed.

  Lemma handleRequestVoteReply_spec :
    forall h st h' t v st',
      st' = handleRequestVoteReply h st h' t v ->
      currentTerm st' = currentTerm st \/
      (currentTerm st <= currentTerm st' /\
       type st' = Follower).
  Proof using.
    intros.
    unfold handleRequestVoteReply, advanceCurrentTerm in *.
    repeat break_match; try find_inversion; subst; simpl in *; intuition;
    do_bool; intuition.
  Qed.

  Lemma cronies_term_request_vote_reply :
    refined_raft_net_invariant_request_vote_reply cronies_term.
  Proof using.
    unfold refined_raft_net_invariant_request_vote_reply, cronies_term.
    intros. subst. simpl in *. repeat find_higher_order_rewrite.
    update_destruct; subst; rewrite_update; eauto.
    simpl in *.
    match goal with
      | H : forall _, st' _ = _ |- _ => clear H
    end.
    unfold update_elections_data_requestVoteReply in *.
    match goal with
      | |- context [handleRequestVoteReply ?h ?st ?h' ?t ?v] =>
        remember (handleRequestVoteReply h st h' t v) as new_state
    end.
    find_copy_apply_lem_hyp handleRequestVoteReply_spec.
    intuition.
    - unfold update_elections_data_requestVoteReply in *.
      break_match; simpl in *; repeat find_rewrite; eauto;
      break_match; eauto;
      subst; repeat find_reverse_rewrite; intuition.
    - unfold update_elections_data_requestVoteReply in *.
      break_match; simpl in *;
      try solve [subst; unfold raft_data in *; congruence].
      eapply le_trans; [|eauto]; eauto.
  Qed.

  Lemma cronies_term_init :
    refined_raft_net_invariant_init cronies_term.
  Proof using.
    unfold refined_raft_net_invariant_init, cronies_term.
    intros. simpl in *. intuition.
  Qed.

  Lemma cronies_term_reboot :
    refined_raft_net_invariant_reboot cronies_term.
  Proof using.
    unfold refined_raft_net_invariant_reboot, cronies_term, reboot.
    intros. simpl in *. repeat find_higher_order_rewrite.
    update_destruct; subst; rewrite_update; eauto.
    simpl in *.
     match goal with
      | H : nwState ?net ?h = (?g, ?st) |- _ =>
        replace g with (fst (nwState net h)) in *; [|rewrite H; auto];
        replace st with (snd (nwState net h)) in *; [|rewrite H; auto]
     end; eauto.
  Qed.

  Lemma cronies_term_state_same_packet_subset :
    refined_raft_net_invariant_state_same_packet_subset cronies_term.
  Proof using.
    unfold refined_raft_net_invariant_state_same_packet_subset, cronies_term.
    intros.
    repeat find_reverse_higher_order_rewrite. eauto.
  Qed.

  Theorem cronies_term_invariant :
    forall net,
      refined_raft_intermediate_reachable net ->
      cronies_term net.
  Proof using rri.
    intros. apply refined_raft_net_invariant; auto.
    - apply cronies_term_init.
    - apply cronies_term_client_request.
    - apply cronies_term_timeout.
    - apply cronies_term_append_entries.
    - apply cronies_term_append_entries_reply.
    - apply cronies_term_request_vote.
    - apply cronies_term_request_vote_reply.
    - apply cronies_term_do_leader.
    - apply cronies_term_do_generic_server.
    - apply cronies_term_state_same_packet_subset.
    - apply cronies_term_reboot.
  Qed.

  Instance cti : cronies_term_interface.
  Proof.
    split.
    auto using cronies_term_invariant.
  Qed.
End CroniesTermProof.


Require Import Crypto.Compilers.Syntax.
Require Import Crypto.Compilers.InlineConstAndOpByRewriteInterp.
Require Import Crypto.Compilers.Z.Syntax.
Require Import Crypto.Compilers.Z.InlineConstAndOpByRewrite.

Module Export Rewrite.
  Definition InterpInlineConstAndOp {t} (e : Expr t)
  : forall x, Interp (InlineConstAndOp e) x = Interp e x
    := @InterpInlineConstAndOp _ _ _ _ _ t e Syntax.Util.make_const_correct.

  Hint Rewrite @InterpInlineConstAndOp : reflective_interp.
End Rewrite.