(*

  Copyright 2014 Cornell University

  This file is part of CFGV project.

  CFGV is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  CFGV is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with CFGV.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/CFGVLFMTP2014/
  Authors: Abhishek Anand & Vincent Rahli

*)
Require Export AlphaEqProps.
Require Import Omega.
Set Implicit Arguments.

(* [lVars] is explicitly a function on [vc].
    the typechecker will then happily export
    the transport in the [pvleaf] clause of [pRenBinders]. *)
Definition lVars {G : CFGV}
  ( vc  : VarSym G) := list (vType vc).

(** renames all binding variables
    to distinct ones that are not
    in [lvAvoid] *)
Fixpoint pRenBinders {G : CFGV}
  { vc  : VarSym G}
  {gs : (GSym G)}
  (lvAvoid : lVars vc)
  (p : Pattern gs)
   {struct p} : Pattern gs  :=
match p in Pattern gs return Pattern gs with
| ptleaf tc t =>  ptleaf tc t
| pvleaf vcc var => pvleaf vcc
                    (match (DeqVarSym vc vcc) with
                    | left eqq => (vFreshVar (transport eqq lvAvoid) var)
                    | right _ => var
                    end)
| pnode p mix => pnode p (mRenBinders lvAvoid mix)
| embed p t => embed p t
end
with mRenBinders {G : CFGV}
  { vc  : VarSym G}
  {lgs : list (bool * GSym G)}
  (lvAvoid : list (vType vc))
   (pts : Mixture lgs)
   {struct pts} : Mixture lgs  :=
match pts with
| mnil => mnil
| mtcons _ _ ph ptl =>  mtcons ph (mRenBinders lvAvoid ptl)
| mpcons _ _ ph ptl => let phr := (pRenBinders lvAvoid ph) in
                       let phrb := pBndngVars vc phr in
                       mpcons phr
                              (mRenBinders (lvAvoid ++ phrb) ptl)
end.

Lemma RenBindersSpec : forall {G : CFGV} (vc  : VarSym G),
(   forall (s : GSym G) (nt : Term s), True)
*
(   forall (s : GSym G) (pt : Pattern s)  (lvAvoid : lVars vc),
    let ptr := (pRenBinders lvAvoid pt) in
    no_repeats (pBndngVars vc ptr)
    # disjoint (pBndngVars vc ptr) lvAvoid
)
*
(   forall (l : list (bool # GSym G)) (m : Mixture l)
    (lvAvoid : lVars vc),
    let mr := (mRenBinders lvAvoid m) in
    no_repeats (mBndngVars vc mr)
    # disjoint (mBndngVars vc mr) lvAvoid
).
Proof.
 intros. GInduction; cpx;[|].
- Case "pvleaf".  allsimpl. intros.
  dands; rewrite DeqSym; ddeq; subst;
  allsimpl; try constructor; cpx.
  repeat (disjoint_reasoning).
  apply vFreshVarSpec.

- Case "mpcons".
  introns Hyp.
  allsimpl. intros.
  specialize (Hyp0 (lvAvoid ++ (pBndngVars vc (pRenBinders lvAvoid ph)))).
  specialize (Hyp lvAvoid ).
  allrw no_repeats_app.
  repnd; dands;cpx; repeat (disjoint_reasoning); cpx.
Qed.

Lemma RenBindersSpec2 : forall {G : CFGV} (vc  : VarSym G),
(   forall (s : GSym G) (nt : Term s), True)
*
(   forall (s : GSym G) (pt : Pattern s)  (lvAvoid : lVars vc),
    pAlreadyBndBinders vc pt
      = pAlreadyBndBinders vc (pRenBinders lvAvoid pt)
)
*
(   forall (l : list (bool # GSym G)) (m : Mixture l)
    (lvAvoid : lVars vc),
    mAlreadyBndBinders vc m
      = mAlreadyBndBinders vc (mRenBinders lvAvoid m)
).
Proof.
  intros; GInduction; allsimpl; cpx;[|]; intros; f_equal; cpx.
Qed.

Lemma RenBindersSpec3 : forall {G : CFGV} (vc  : VarSym G),
(   forall (s : GSym G) (nt : Term s), True)
*
(   forall (s : GSym G) (pt : Pattern s)  (lvAvoid : lVars vc),
    pAllButBinders vc pt
      = pAllButBinders vc (pRenBinders lvAvoid pt)
)
*
(   forall (l : list (bool # GSym G)) (m : Mixture l)
    (lvAvoid : lVars vc),
    mAllButBinders vc m
      = mAllButBinders vc (mRenBinders lvAvoid m)
).
Proof.
  intros; GInduction; allsimpl; cpx;
      [|]; intros; f_equal; cpx.
Qed.

(*
Fixpoint mSwapTermEmbed
       {G  : CFGV}
       {vc : VarSym G}
       {lgs : list (bool * GSym G)}
       (pts : Mixture lgs)
       (sw : list (Swapping vc))
       {struct pts}
     : Mixture lgs  :=
match pts with
| mnil => mnil
| mtcons _ _ th ttl =>
    mtcons (tSwap th (lhead sw))
           (mSwapTermEmbed ttl (tail sw))
| mpcons _ _ ph ptl =>
    mpcons (pSwapEmbed ph  (lhead sw))
           (mSwapTermEmbed ptl  (tail sw))
end.
*)

Fixpoint mLSwapTermEmbed
       {G  : CFGV}
       {vc : VarSym G}
       {lgs : list (bool * GSym G)}
       (pts : Mixture lgs)
       (llbvOld llbvNew : list (lVars vc))
       {struct pts}
     : Mixture lgs  :=
match pts with
| mnil => mnil
| mtcons _ _ th ttl =>
    mtcons (tSwap th (combine (lhead llbvOld) (lhead llbvNew)))
           (mLSwapTermEmbed ttl (tail llbvOld) (tail llbvNew))
| mpcons _ _ ph ptl =>
    mpcons (pSwapEmbed ph (combine (lhead llbvOld) (lhead llbvNew)))
           (mLSwapTermEmbed ptl (tail llbvOld) (tail llbvNew))
end.

Definition nodeRenAlphaAux
   {G : CFGV} {vc : VarSym G}
   {mp : MixtureParam}
   (lln : list (list nat))
   (rmix : Mixture mp)
   (lvAvoid : list (vType vc))
  : Mixture mp :=

  if (decDisjointV vc (mBndngVars vc rmix) lvAvoid)
  then
    rmix
  else
    let llbvOld := lBoundVars vc lln rmix in
    let rmixPR := mRenBinders (lvAvoid ++ (mAllVars rmix)) rmix in
    let llbvNew := lBoundVars vc lln rmixPR in
    mLSwapTermEmbed rmixPR llbvOld llbvNew.

Fixpoint tRenAlpha {G : CFGV} {vc : VarSym G}
  {gs : (GSym G)} (pt : Term gs)
   (lvAvoid : list (vType vc))
   {struct pt} :  Term gs :=
match pt in Term gs return Term gs with
| tleaf a b => tleaf a b
| vleaf vcc var => vleaf vcc var
| tnode p mix => tnode p
      ( let rmix := mRenAlpha mix lvAvoid in
        nodeRenAlphaAux (bndngPatIndices p) rmix lvAvoid
        )
end

with pRenAlpha {G : CFGV} {vc : VarSym G}
  {gs : (GSym G)} (pt : Pattern gs)
  (lvAvoid : list (vType vc)) {struct pt} : Pattern gs  :=
match pt with
| ptleaf a v => ptleaf a v
| pvleaf vcc var => pvleaf vcc var
| pnode p lpt => pnode p (mRenAlpha lpt lvAvoid)
| embed p nt => embed p (tRenAlpha nt lvAvoid)
end

with mRenAlpha {G : CFGV} {vc : VarSym G}
  {lgs : list (bool * GSym G)} (pts : Mixture lgs)
  (lvAvoid : list (vType vc))
 {struct pts}
      : Mixture lgs  :=
match pts in Mixture lgs return Mixture lgs with
| mnil  => mnil
| mtcons _ _ th ttl =>
        mtcons (tRenAlpha th lvAvoid)
               (mRenAlpha ttl lvAvoid)
| mpcons _ _ ph ptl =>
        mpcons  (pRenAlpha ph lvAvoid)
                (mRenAlpha ptl lvAvoid)
end.

Definition AvRenaming {G : CFGV} {vc : VarSym G}
(lvA : list (vType vc)) (sw : Swapping vc)
:= no_repeats (ALRange sw)
    # disjoint (ALDom sw) (ALRange sw)
    # disjoint (ALRange sw) lvA .

Lemma AvRenamingSubset : forall
   {G : CFGV} {vc : VarSym G}
(lvl lvr : list (vType vc))
(sw : Swapping vc),
subset lvr lvl
-> AvRenaming lvl sw
-> AvRenaming lvr sw.
Proof.
  unfold AvRenaming.
  introv Hs Hav. repnd.
  dands; cpx.
  SetReasoning.
Qed.

Lemma ndRenAlAxSpecDisjAux : forall
   {G : CFGV} {vc : VarSym G}
   {mp : MixtureParam}
   (pts : Mixture mp)
  (llbvOld llbvNew : list (lVars vc))
  (lvA : list (vType vc)),
  disjoint (mAlreadyBndBinders vc pts) lvA
  -> lForall no_repeats llbvNew
  -> disjoint (flatten llbvNew) (lvA ++
          mAllButBinders vc pts ++ flatten llbvOld)
  -> map (@length _) llbvOld =  map (@length _) llbvNew
  -> length llbvOld = length mp
  -> disjoint (mAlreadyBndBinders vc pts ++ mBndngVars vc pts) lvA
  -> disjoint (mBndngVarsDeep vc (mLSwapTermEmbed pts llbvOld llbvNew))
             lvA.
Proof.
  induction pts; cpx;[|].
- introv H1a H2a H3a H4a H5a H6a.
  applydup map_eq_length_eq in H4a.
  allsimpl. dlist_len llbvOld. allsimpl.
  dlist_len llbvNew. allsimpl.
  inverts H4a.
  allrw no_repeats_app.
  repeat (disjoint_reasoning).
  + GC.
    apply tSwapBndngVarsDisjoint; cpx;
    repeat(disjoint_reasoning).
  + allsimpl. exrepnd.
    apply IHpts; cpx; repeat(disjoint_reasoning).

- introv H1a H2a H3a H4a H5a H6a.
  applydup map_eq_length_eq in H4a.
  allsimpl. dlist_len llbvOld. allsimpl.
  dlist_len llbvNew. allsimpl.
  inverts H4a.
  allrw no_repeats_app.
  repeat (disjoint_reasoning).
  + GC. apply disjoint_sym.
    apply (pcase SwapEmbedSpec); cpx;
    autorewrite with fast; try congruence;
     cpx;  repeat (disjoint_reasoning).
  + allsimpl. exrepnd.
    apply IHpts; cpx; repeat(disjoint_reasoning).
Qed.

Lemma mRenBindersSpec3 : forall
  {G : CFGV} {vc  : VarSym G}
   {mp : MixtureParam}
   (pts : Mixture mp)
   (lln : list (list nat))
   (lvAvoid : list (vType vc)),
   validBsl (length mp) lln
  ->
lForall no_repeats
  (lBoundVars vc lln (mRenBinders (lvAvoid) pts)).
Proof.
  intros.
  pose proof  ((mcase (RenBindersSpec vc)) _ pts lvAvoid)  as Hs.
  simpl in Hs.
  repnd.
  rewrite mBndngVarsAsNth in Hs0. clear Hs.
  rw (@lForallSame (list (vType vc))).
  unfold lBoundVars.
  introv Hin.
  apply in_map_iff in Hin.
  exrepnd. subst. rename a0 into ln.
  apply X in Hin1.
  repnud Hin1.
  induction ln; cpx.
  allrw no_repeats_cons.
  allsimpl. repnd.
  apply IHln in Hin2; cpx;[].
  clear IHln.
  allrw no_repeats_app.
  dands;cpx.
  - apply  no_rep_flat_map_seq1 with (n:=0) (len := length mp); sp.
    apply LInSeqIff; dands; omega.
  - intros. introv Hin Hinc.
    apply lin_flat_map in Hinc.
    exrepnd.
    destruct (deq_nat x a); subst; cpx.
    (* for diff indices, they are disjoint *)
    eapply no_rep_flat_map_seq2 in n; eauto.
    + disjoint_lin_contra.
    + rw (@lForallSame nat) in Hin1.
      apply Hin1 in Hinc1.
      apply LInSeqIff; dands; omega.
    + apply LInSeqIff; dands; omega.
Qed.

Theorem renBindersSameLength: forall
{G : CFGV} {vc : VarSym G},
(   forall (s : GSym G) (nt : Term s), True)
*
(   forall (s : GSym G) (pt : Pattern s) (lvA : lVars vc),
    length (pBndngVars vc pt)
      = length (pBndngVars  vc (pRenBinders lvA pt))
)
*
(   forall (l : list (bool # GSym G)) (m : Mixture l)
    (lvA : lVars vc)
    (nn : nat),
    length (getBVarsNth vc m nn) =
        length (getBVarsNth vc (mRenBinders lvA m) nn)
).
Proof.
  intros.
 GInduction; allsimpl; introns Hyp; intros; cpx;
[ | | | ].
  - Case "pvleaf". rewrite DeqSym.
    symmetry. rewrite DeqSym.
    ddeq; subst; sp.

  - Case "pnode".
    simpl. simpl pBndngVars.
    rewrite mBndngVarsAsNth.
    rewrite mBndngVarsAsNth.
    rewrite len_flat_map.
    rewrite len_flat_map.
    f_equal.
    apply eq_maps.
    cpx.
  - simpl. destruct nn; cpx.
  - simpl. destruct nn; cpx.
Qed.

Lemma renBindersLBVLenSame :
forall {G : CFGV} {vc : VarSym G}
(l : list (bool # GSym G)) (pts : Mixture l)
    (lvA : lVars vc)
    (lln : list (list nat)),
map (@length _) (lBoundVars vc lln pts) =
map (@length _) (lBoundVars vc lln (mRenBinders lvA pts)).
Proof.
  intros.
  apply lBoundVarsLenSameifNth.
  pose proof (@renBindersSameLength G vc).
  dands; cpx.
Qed.

Hint Resolve (fun G vc => mcase (@ bindersAllvarsSubset G vc))
 lBoundVarsmBndngVars :
  SetReasoning.

Lemma ndRenAlAxSpecDisj : forall
  {G : CFGV} {vc  : VarSym G}
   {mp : MixtureParam}
   (pts : Mixture mp)
   (lln : list (list nat))
   (lvAvoid : list (vType vc)),
   validBsl (length mp) lln
  -> length lln = length mp
  -> disjoint (mAlreadyBndBinders vc pts) lvAvoid
  -> disjoint (mBndngVarsDeep vc (nodeRenAlphaAux lln pts lvAvoid))
             lvAvoid.
Proof.
  introv Hnr Hlen Hdis.
  unfold nodeRenAlphaAux.
  cases_ifd Hdddd; cpx;
    [ apply disjointDeepShallowPlusAlready;
      repeat (disjoint_reasoning) |].
  pose proof ((mcase (RenBindersSpec vc)) _ pts (lvAvoid ++ mAllVars pts))  as Hs.
  simpl in Hs. exrepnd.
  apply ndRenAlAxSpecDisjAux;
  try rewrite <- (mcase (RenBindersSpec2 vc));
  try rewrite <- (mcase (RenBindersSpec3 vc)); cpx.
  - apply mRenBindersSpec3; cpx.
  - eapply subset_disjointLR; eauto.
    + apply lBoundVarsmBndngVars.
    + apply subset_app_lr; eauto;[].
      apply subset_app. dands;
      eauto 2 with SetReasoning.
  - apply renBindersLBVLenSame.
  - unfold lBoundVars.
    autorewrite with fast. trivial.
  - repeat (disjoint_reasoning).
Qed.

Lemma RenAlphaAvoid : forall {G : CFGV} {vc  : VarSym G},
(  (forall (s : GSym G) (ta : Term s)
  (lvA : list (vType vc)),
      disjoint (tBndngVarsDeep vc (tRenAlpha ta lvA)) lvA)
   *
  (forall (s : GSym G) (pta : Pattern s)
  (lvA : list (vType vc)),
      disjoint (pAlreadyBndBinders vc (pRenAlpha pta lvA)) lvA)

   *
  (forall (l : MixtureParam) (ma: Mixture l)
  (lvA : list (vType vc)),
      disjoint (mAlreadyBndBinders vc (mRenAlpha ma lvA)) lvA)).
Proof.
intros. GInduction; intros; cpx;
  try (allsimpl; repeat (disjoint_reasoning); cpx; fail);[].
  Case "tnode".
  allsimpl.
  specialize (H lvA).
  remember (mRenAlpha m lvA) as pts.
  apply ndRenAlAxSpecDisj; auto.
  - rewrite length_pRhsAugIsPat.
    apply bndngPatIndicesValid2; auto.

  - unfold bndngPatIndices.
    unfold tpRhsAugIsPat. unfold prhsIsBound.
    rw combine_length.
    unfold tpRhsSym. simpl.
    autorewrite with fast.
    rw min_eq; auto.
Qed.

Theorem lbShallowNoChange: forall
  {G : CFGV} {vc : VarSym G},
(   forall (s : GSym G) (nt : Term s), True)
*
(   forall (s : GSym G) (pt : Pattern s)
    (lvA : list (vType vc)),
    pBndngVars vc pt = pBndngVars  vc (pRenAlpha pt lvA)
)
*
(   forall (l : list (bool # GSym G)) (m : Mixture l)
    (lvA : list (vType vc))
    (nn : nat),
    getBVarsNth vc m nn = @getBVarsNth
                            _ vc _ (mRenAlpha m lvA) nn
).
 intros.
  GInduction; allsimpl; introns Hyp; intros; cpx;[ | | ].
  - Case "pnode". simpl. simpl pBndngVars.
    rewrite mBndngVarsAsNth.
    rewrite mBndngVarsAsNth.
    autorewrite with fast.
    apply eq_flat_maps.
    intros nn Hin. cpx.
  - simpl. destruct nn; cpx.
  - simpl. destruct nn; cpx.
Qed.

Lemma  mRenlBinderShallowSame : forall
  {G : CFGV} {vc : VarSym G}
 (l : MixtureParam) (m : Mixture l)
 (lvA : list (vType vc))
  (la : list (list nat)),
lBoundVars vc la m =  lBoundVars vc la (mRenAlpha m lvA).
Proof.
  intros. apply lBoundVarsSameifNth.
  apply (mcase lbShallowNoChange).
Qed.

Lemma  mBndngVarsShallowSame : forall
  {G : CFGV} {vc : VarSym G}
 (l : MixtureParam) (m : Mixture l)
 (lvA : list (vType vc)),
  mBndngVars vc m =  mBndngVars vc (mRenAlpha m lvA).
Proof.
  intros. apply mBndngVarsSameIfNth.
  apply (mcase lbShallowNoChange).
Qed.

Lemma mLSwapTermEmbedSameBinders : forall
   {G : CFGV} {vc : VarSym G}
   {mp : MixtureParam}
   (m : Mixture mp)
   (lla llb : list (list (vType vc))),
(mBndngVars vc (mLSwapTermEmbed m lla llb))
  = mBndngVars vc m.
Proof.
  induction m; cpx;[].
  simpl. intros.
  f_equal; cpx;[].
  symmetry.
  apply (pcase SwapEmbedSameBinders).
Qed.

Lemma mLSwapTermEmbedSameNthBinder : forall
   {G : CFGV} {vc : VarSym G}
   {mp : MixtureParam}
   (m : Mixture mp)
   (lla llb : list (list (vType vc)))
   (nn : nat),
    getBVarsNth vc m nn = getBVarsNth
                             vc (mLSwapTermEmbed m lla llb) nn.
Proof.
  induction m; cpx; intros ; destruct nn; allsimpl; cpx.
  apply (pcase SwapEmbedSameBinders).
Qed.

Lemma pRenBindersAlpha : forall {G : CFGV} {vc : VarSym G},
(  (forall (s : GSym G) (ta : Term s), True)
   *
  (forall (s : GSym G) (pta : Pattern s)
  (lvA : list (vType vc)),
      pAlphaEq vc pta (pRenBinders lvA pta))
   *
  (forall (mp : MixtureParam) (ma: Mixture mp)
  (llbv : list (list (vType vc)))
  (lvA : list (vType vc)),
  (forall b s, LIn (b,s) mp -> b= true)
  -> let maR := mRenBinders lvA ma in
    lAlphaEqAbs (MakeAbstractions vc ma llbv)
                (MakeAbstractions vc maR llbv))).
Proof.
intros.
GInduction; cpx; allsimpl;
  try (econstructor; eauto with Alpha; fail).
- Case "pnode". introns Hyp.
  allsimpl. constructor.
  unfold MakeAbstractionsPNode.
  apply Hyp.
  introv Hin.
  apply in_map_iff in Hin; exrepnd; cpx.
Qed.

Lemma mLSwapTermEmbedSameLBV : forall
   {G : CFGV} {vc : VarSym G}
   {mp : MixtureParam}
   (m : Mixture mp)
   (lla llb : list (list (vType vc)))
   (lln : list (list nat)),
    lBoundVars vc lln m = lBoundVars
                             vc  lln (mLSwapTermEmbed m lla llb).
Proof.
  intros.
  apply lBoundVarsSameifNth.
  apply mLSwapTermEmbedSameNthBinder.
Qed.

Definition swapEmbedAbs {G : CFGV} {vc : VarSym G}
           (a : Abstraction G vc)
           (sw : Swapping vc)
    : (Abstraction G vc):=
match a with
| termAbs _ lbv t =>  termAbs _ lbv t
| patAbs _ lbv t => patAbs _ lbv (pSwapEmbed t sw)
end.

Definition swapEmbedLAbs {G : CFGV} {vc : VarSym G}
           (la : list (Abstraction G vc))
           (sw : Swapping vc)
    : list (Abstraction G vc):=
map (fun x => swapEmbedAbs x sw) la.

Lemma MakeLAbsSwapCommute:
forall {G : CFGV} {vc : VarSym G} (mp : MixtureParam)
  (sw : Swapping vc) (m : Mixture mp)
  (lbv : list (lVars vc)),
swapEmbedLAbs (MakeAbstractions vc m lbv) sw =
MakeAbstractions vc (mSwapEmbed m sw) lbv.
Proof.
  unfold swapEmbedLAbs.
  intros G vc np sw m.
  induction m;  intros; allsimpl; cpx; f_equal; cpx;
   destruct lbv; allsimpl; cpx.
Qed.

Lemma ndRenAlAxAlpha : forall
   {G : CFGV} {vc : VarSym G}
   {mp : MixtureParam}
   (m : Mixture mp)
   (lln : list (list nat))
   (lvA : list (vType vc)),
   validBsl (length mp) lln
  ->
lAlphaEqAbs (MakeAbstractionsTNodeAux vc lln m)
  (MakeAbstractionsTNodeAux vc lln (nodeRenAlphaAux lln m lvA)).
Proof.
  unfold MakeAbstractionsTNodeAux.
  introv Hv.
  unfold nodeRenAlphaAux.
  cases_ifd Hdddd; cpx; eauto with Alpha;[]; clear Hddddf.
  rewrite <- mLSwapTermEmbedSameLBV.
  pose proof (renBindersLBVLenSame m (lvA ++ mAllVars m) lln) as Hlen.
  pose proof (@mRenBindersSpec3 G vc
      mp m lln (lvA ++ mAllVars m)) as Hnr.
  apply Hnr in Hv.
  clear Hnr.
  pose proof
    ((mcase (RenBindersSpec vc)) _
      m (lvA ++ mAllVars m))  as Hd.
  simpl in Hd.
  repnd. clear Hd0.
  assert (
      disjoint
        (flatten (lBoundVars vc lln
          (mRenBinders (lvA ++ mAllVars m) m)))
       (lvA ++ (flatten (lBoundVars vc lln m)))
    ) as Hld by
    (apply (subset_disjointLR Hd); auto;
    [ eauto with SetReasoning |
    apply subset_app_lr; eauto 2 with SetReasoning]).

  assert (
      disjoint
        (flatten (lBoundVars vc lln
          (mRenBinders (lvA ++ mAllVars m) m)))
       (lvA ++ (mAllVars m))
    ) as Had by
    (apply (subset_disjointLR Hd); eauto with SetReasoning).

    clear Hd.
  repeat disjoint_reasoning.
  clear Had0 Hld0.
  remember (lBoundVars vc lln m) as lbva.
  remember (lBoundVars vc lln
    (mRenBinders (lvA ++ mAllVars m) m)) as lbvb.
  applydup map_eq_length_eq in Hlen.
  clear Heqlbvb.
  clear Heqlbva.
  remember (lvA ++ mAllVars m) as lv.
  clear Heqlv.
  revert lv.
  generalize dependent lbvb.
  generalize dependent lbva.
  clear lln lvA.
  induction m as [ | ? ? ph ptl Hind| ? ? ph ptl Hind]; cpx.
- allsimpl. intros. constructor; cpx.
  + destruct lbva as [|la lvba]; allsimpl;
    destruct lbvb as [|lb lbvv];
    inverts Hlen0;
    autorewrite with fast; simpl;
    [apply AlphaEqNilAbsT; eauto with Alpha; fail|].
    pose proof (GFreshDistRenWSpec vc la
                (tAllVars ph++
                (tAllVars (tSwap ph (combine la lb)))
                    ++ la ++lb)) as Hfr.
    exrepnd.
    allsimpl. inverts Hlen.
    apply alAbT with (lbnew:=lvn); try congruence;
    repeat (disjoint_reasoning);
    [unfolds_base; simpl; dands; cpx;
    autorewrite with fast;
    repeat(disjoint_reasoning); fail |].

    rewrite (tcase swap_app).
    autorewrite with slow; try congruence;
    cpx; repeat (disjoint_reasoning);
    eauto with Alpha.

  + apply Hind; destruct lbva; destruct lbvb;
    allsimpl; repeat (disjoint_reasoning);
    inverts Hlen0; inverts Hlen; cpx.

- allsimpl. intros. constructor; cpx.
  + eapply alphaEqTransitive.
    instantiate (1 :=
    (patAbs vc (lhead lbvb)
       (pSwap ph
        (combine (lhead lbva) (lhead lbvb))))
   ).

   *  destruct lbva as [|la lvba]; allsimpl;
      destruct lbvb as [|lb lbvv];
      inverts Hlen0;
      autorewrite with fast; simpl;
      [apply AlphaEqNilAbsP; eauto with Alpha; fail|].
      pose proof (GFreshDistRenWSpec vc la
                  (pAllVars ph++
                  (pAllVars (pSwap ph (combine la lb)))
                      ++ la ++lb)) as Hfr.
      exrepnd.
      allsimpl. inverts Hlen.
      apply alAbP with (lbnew:=lvn); try congruence;
      repeat (disjoint_reasoning);
      [unfolds_base; simpl; dands; cpx;
      autorewrite with fast;
      repeat(disjoint_reasoning) |].

      rewrite (pcase swap_app).
      autorewrite with slow; try congruence;
      cpx; repeat (disjoint_reasoning);
      eauto with Alpha.

   * apply AlphaEqNilAbsP.
     apply alphaEqSym.
  eapply alphaEqTransitive.
    instantiate (1 :=
        (pSwap (pRenBinders lv ph)
            (combine (lhead lbva) (lhead lbvb)))
   ).
     apply  (pcase (@pAlphaSwapEmSwap G vc)).
     apply alphaEqSym.
     apply alphaEquiVariant.
     apply pRenBindersAlpha.
  + apply Hind; destruct lbva; destruct lbvb;
    allsimpl; repeat (disjoint_reasoning);
    inverts Hlen0; inverts Hlen; cpx.
Qed.

Lemma RenAlphaAlpha : forall {G : CFGV} {vc : VarSym G},
(  (forall (s : GSym G) (ta : Term s)
  (lvA : list (vType vc)),
      tAlphaEq vc ta (tRenAlpha ta lvA))
   *
  (forall (s : GSym G) (pta : Pattern s)
  (lvA : list (vType vc)),
      pAlphaEq vc pta (pRenAlpha pta lvA))
   *
  (forall (l : MixtureParam) (ma: Mixture l)
  (llbv : list (list (vType vc)))
  (lvA : list (vType vc)),
  let maR := mRenAlpha ma lvA in
    lAlphaEqAbs (MakeAbstractions vc ma llbv)
                (MakeAbstractions vc maR llbv))).
Proof.
intros. GInduction; intros; cpx;
  try (econstructor; eauto; fail);[| |].

- Case "tnode".
  allsimpl.
  constructor.
  unfold MakeAbstractionsTNode.
  unfold nodeRenAlphaAux.

  eapply (alphaEqTransitive);
  [ |apply ndRenAlAxAlpha with (lvA0 := lvA); eauto].
  unfold MakeAbstractionsTNodeAux.
  rw <- (@mRenlBinderShallowSame G vc).
  apply X; cpx.
  unfold tpRhsAugIsPat. unfold prhsIsBound.
  rw combine_length.
  unfold tpRhsSym.
  autorewrite with fast.
  rw min_eq; auto.
  apply bndngPatIndicesValid2; auto.
- Case "mtcons".
  subst maR.
  allunfold MakeAbstractionsTNodeAux.
  simpl. constructor; cpx.
  apply AlphaEqNilAbsT; cpx.

- Case "mpcons".
  subst maR.
  allunfold MakeAbstractionsTNodeAux.
  simpl. constructor; cpx.
  apply AlphaEqNilAbsP; cpx.

Qed.

Ltac addRenSpec :=
match goal with
[ |- context [@tRenAlpha ?G ?vc ?gs ?a ?lv] ]
  =>  let Hala := fresh "Hal" a in
      let Hdis := fresh "Hdis" a in
      pose proof ((tcase (@RenAlphaAlpha G vc))
              gs a lv) as Hala;
      pose proof ((tcase (@RenAlphaAvoid G vc))
              gs a lv) as Hdisa
end.

Lemma RenAlphaNoChange : forall {G : CFGV} {vc : VarSym G},
(  (forall (s : GSym G) (ta : Term s)
  (lvA : list (vType vc)),
    disjoint (tBndngVarsDeep vc ta) lvA
      -> ta = (tRenAlpha ta lvA))
   *
  (forall (s : GSym G) (pta : Pattern s)
  (lvA : list (vType vc)),
    disjoint (pBndngVarsDeep vc pta) lvA
      -> pta = (pRenAlpha pta lvA))
   *
  (forall (l : MixtureParam) (ma: Mixture l)
  (lvA : list (vType vc)),
    disjoint (mBndngVarsDeep vc ma) lvA
    -> ma = mRenAlpha ma lvA)).
Proof.
  intros.
  GInduction; introns Hyp; allsimpl;
  try (f_equal; cpx; fail);[ | | ].

- Case "tnode". f_equal.
  unfolds_base.
  cases_ifd Hdd; cpx.
  rewrite <- mBndngVarsShallowSame in Hddf.
  provefalse. apply Hddf.
  SetReasoning.

- Case "mtcons". allsimpl. repeat (disjoint_reasoning).
  f_equal; cpx.

- Case "mpcons". allsimpl. repeat (disjoint_reasoning).
  f_equal; cpx.
Qed.

Lemma tRenWithSpec :
  forall  {G : CFGV} {vc : VarSym G}
     (s : GSym G) (ta : Term s)
     (lvA : list (vType vc)),
  {tar : Term s $ tAlphaEq vc ta tar #
          disjoint (tBndngVarsDeep vc tar) lvA}.
Proof.
  intros.
  exists (tRenAlpha ta lvA).
  pose proof (@RenAlphaAlpha G vc).
  pose proof (@RenAlphaAvoid G vc).
  repnd.
  dands; cpx.
Qed.

(* only comments below *)

(*
Lemma AllVarsEquivariant :
  forall {G : CFGV} {vc : VarSym G}
  (sw : Swapping vc),
    (forall (gs : GSym G) (t : Term gs), True)
    *
    (forall (gs : GSym G),
    EquiVariantFn (@pSwap _ vc gs)
                  (@pSwap _ vc gs)
                  (fun t => pSwapEmbed t sw))
    *
    (forall (lgs : list (bool * GSym G)),
     EquiVariantFn (@mSwap _ vc lgs)
                (@mSwap _ vc lgs)
                (fun t => mSwapEmbed t sw)).
Proof.
  intros.
  GInduction; auto; introns Hyp; intros; allsimpl ; auto.

- Case "pembed". f_equal.

simpl. rewrite DeqSym. symmetry. rewrite DeqSym.
  destruct_head_match; try subst;  cpx.

- simpl. rewrite DeqSym. symmetry. rewrite DeqSym.
  destruct_head_match; try subst;  cpx.

- unfold swapLVar. rw map_app.
  unfold swapLVar in Hyp0.
  unfold swapLVar in Hyp.
  f_equal; cpx.

- unfold swapLVar. rw map_app.
  unfold swapLVar in Hyp0.
  unfold swapLVar in Hyp.
  f_equal; cpx.
Qed.
*)

(*
Lemma swapDisjChain : forall  {G : CFGV} {vc : VarSym G}
  (vsa vs vsb : lVars vc),
    length vs = length vsa
    -> length vs = length vsb
    -> no_repeats vs
    -> no_repeats vsb
    ->
  ((forall (gs : GSym G) (t : Term gs), True)
  *
  (forall (gs : GSym G) (t : Pattern gs),
       disjoint vs (vsa ++ vsb ++ (pAllVars t))
       -> disjoint vsb (vsa ++ pAllVars t)
       -> (pSwap (pSwapEmbed t (combine vsa vs)) (combine vs vsb))
            = pSwap t (combine vsa vsb))

    *
  (forall (lgs : MixtureParam) (m : Mixture lgs) ,
       disjoint vs (vsa ++ vsb ++ (mAllVars m))
       -> disjoint vsb (vsa ++ mAllVars m)
       -> (mSwap (mSwapEmbed m (combine vsa vs)) (combine vs vsb))
            = mSwap m (combine vsa vsb))).
Proof.
  introv Hlena Hlenb Hnr Hnrb.
  apply GInduction; auto; introns Hdis; allsimpl.

  - Case "vleaf". simpl. f_equal. rewrite DeqSym. symmetry.  rewrite DeqSym.
    destruct_head_match; cpx.
    subst.
    allsimpl. symmetry.
    rewrite swapVarNoChange; allsimpl;
    repeat(disjoint_reasoning); cpx.
    allrewrite (@DeqTrue (VarSym G)); allsimpl;
    repeat(disjoint_reasoning).

  - Case "pnode".
    rw Hdis; simpl; auto.

  - Case "pvleaf". simpl. f_equal. rewrite DeqSym. symmetry.  rewrite DeqSym.
    destruct_head_match; cpx.
    subst.
    simpl. symmetry. apply swapVarDisjChain; auto;
    repeat(disjoint_reasoning); allsimpl;
    allrewrite (@DeqTrue (VarSym G)); allsimpl;
    repeat(disjoint_reasoning).

  - rw Hdis; simpl; auto.
  - rw Hdis; simpl; auto.
  - f_equal.
    + apply Hdis; repeat(disjoint_reasoning).
    + apply Hdis0; repeat(disjoint_reasoning).

  - f_equal.
    + apply Hdis; repeat(disjoint_reasoning).
    + apply Hdis0; repeat(disjoint_reasoning).
Qed.
*)

(*
Lemma alphaSwapEmbedCongr : forall {G : CFGV} {vc : VarSym G},
(
  (forall (s : GSym G) (a b : Term s), tAlphaEq vc a b -> True)
   *
  (forall (s : GSym G),
      EquiVariantRelSame (@pSwapEmbed G vc s) (pAlphaEq vc))
  *
  (EquiVariantRelSame (@swapEmbedAbs G vc) (@AlphaEqAbs G vc))
  *
  (EquiVariantRelSame (@swapEmbedLAbs G vc) (@lAlphaEqAbs G vc))
).
Proof.
  intros. GAlphaInd; introns Hyp; intros;
  allsimpl; try (econstructor; eauto with Alpha; fail);[ | |].
- Case "pembed". constructor.
  apply alphaEquiVariant; eauto.
- Case "pnode". constructor.
  unfold MakeAbstractionsPNode.
  rewrite <-  MakeLAbsSwapCommute.
  rewrite <-  MakeLAbsSwapCommute.
  cpx.

- Case "patAbs".
  specialize (Hyp4 sw).
Qed.
*)


Require Import Coq.Lists.List.
Import ListNotations.
Require Import Coq.Strings.String.

Require Import FFI.
Require Import CakeSem.Namespace.
Require Import CakeSem.CakeAST.
Require Import CakeSem.SemanticsAux.
Require Import CakeSem.Evaluate.

Require Import NoBasis.

Definition init_env : sem_env val := empty_sem_env.
Definition init_store := empty_store val.

Parameter A : Type.
Parameter init_ffi_st : ffi_state A.
Definition init_state := Build_state 0 init_store init_ffi_st 0 0.

Definition noBasisProg := evaluate_decs 100 init_state init_env [ dec_def_0
                                                                ; dec_def_1
                                                                ; dec_def_2
                                                                ; dec_def_3
                                                                ; dec_def_4
                                                                ; dec_def_5
                                                                ; dec_def_6
                                                                ; dec_def_7
                                                                ; dec_def_8
                                                                ; dec_def_9
                                                                ; dec_def_10
                                                                ].

Definition noBasisProg' := evaluate_decs 19 init_state init_env [ dec_def_0
                                                                ; dec_def_1
                                                                ; dec_def_2
                                                                ; dec_def_3
                                                                ; dec_def_4
                                                                ; dec_def_5
                                                                ; dec_def_6
                                                                ; dec_def_7
                                                                ; dec_def_8
                                                                ; dec_def_9
                                                                ].
Eval cbv in noBasisProg.

Definition my_env :=   {|
         sev := [(Short "answer",
                 Conv (Some (TypeStamp "S" 0))
                   [Conv (Some (TypeStamp "S" 0))
                      [Conv (Some (TypeStamp "S" 0))
                         [Conv (Some (TypeStamp "S" 0)) [Conv (Some (TypeStamp "S" 0)) [Conv (Some (TypeStamp "O" 0)) []]]]]]);
                (Short "three",
                Conv (Some (TypeStamp "S" 0))
                  [Conv (Some (TypeStamp "S" 0)) [Conv (Some (TypeStamp "S" 0)) [Conv (Some (TypeStamp "O" 0)) []]]]);
                (Short "two",
                Conv (Some (TypeStamp "S" 0)) [Conv (Some (TypeStamp "S" 0)) [Conv (Some (TypeStamp "O" 0)) []]]);
                (Short "abs_minus",
                Recclosure
                  {|
                  sev := [(Short "minus",
                          Recclosure
                            {|
                            sev := [];
                            sec := [(Short "SubtrahendLargerThanMinuend", (0, ExnStamp 0));
                                   (Short "S", (1, TypeStamp "S" 0)); (Short "O", (0, TypeStamp "O" 0))] |}
                            [("minus", "x",
                             EFun "y"
                               (ELannot
                                  (EMat (ELannot (EVar (Short "y")) [0])
                                     [(Pcon (Some (Short "O")) [], ELannot (EVar (Short "x")) [0]);
                                     (Pcon (Some (Short "S")) [Pvar "yp"],
                                     ELannot
                                       (EMat (ELannot (EVar (Short "x")) [0])
                                          [(Pcon (Some (Short "O")) [],
                                           ELannot
                                             (ERaise (ELannot (ECon (Some (Short "SubtrahendLargerThanMinuend")) []) [0]))
                                             [0]);
                                          (Pcon (Some (Short "S")) [Pvar "xp"],
                                          ELannot
                                            (EApp Opapp
                                               [ELannot
                                                  (EApp Opapp
                                                     [ELannot (EVar (Short "minus")) [0]; ELannot (EVar (Short "xp")) [0]])
                                                  [0]; ELannot (EVar (Short "yp")) [0]]) [0])]) [0])]) [0]))] "minus");
                         (Short "minus",
                         Recclosure
                           {|
                           sev := [];
                           sec := [(Short "SubtrahendLargerThanMinuend", (0, ExnStamp 0));
                                  (Short "S", (1, TypeStamp "S" 0)); (Short "O", (0, TypeStamp "O" 0))] |}
                           [("minus", "x",
                            EFun "y"
                              (ELannot
                                 (EMat (ELannot (EVar (Short "y")) [0])
                                    [(Pcon (Some (Short "O")) [], ELannot (EVar (Short "x")) [0]);
                                    (Pcon (Some (Short "S")) [Pvar "yp"],
                                    ELannot
                                      (EMat (ELannot (EVar (Short "x")) [0])
                                         [(Pcon (Some (Short "O")) [],
                                          ELannot
                                            (ERaise (ELannot (ECon (Some (Short "SubtrahendLargerThanMinuend")) []) [0]))
                                            [0]);
                                         (Pcon (Some (Short "S")) [Pvar "xp"],
                                         ELannot
                                           (EApp Opapp
                                              [ELannot
                                                 (EApp Opapp
                                                    [ELannot (EVar (Short "minus")) [0]; ELannot (EVar (Short "xp")) [0]])
                                                 [0]; ELannot (EVar (Short "yp")) [0]]) [0])]) [0])]) [0]))] "minus")];
                  sec := [(Short "SubtrahendLargerThanMinuend", (0, ExnStamp 0)); (Short "S", (1, TypeStamp "S" 0));
                         (Short "O", (0, TypeStamp "O" 0))] |}
                  [("abs_minus", "x",
                   EFun "y"
                     (ELannot
                        (EHandle
                           (ELannot
                              (EApp Opapp
                                 [ELannot (EApp Opapp [ELannot (EVar (Short "minus")) [0]; ELannot (EVar (Short "x")) [0]])
                                    [0]; ELannot (EVar (Short "y")) [0]]) [0])
                           [(Pcon (Some (Short "SubtrahendLargerThanMinuend")) [],
                            ELannot
                              (EApp Opapp
                                 [ELannot (EApp Opapp [ELannot (EVar (Short "minus")) [0]; ELannot (EVar (Short "y")) [0]])
                                    [0]; ELannot (EVar (Short "x")) [0]]) [0])]) [0]))] "abs_minus");
                (Short "minus",
                Recclosure
                  {|
                  sev := [];
                  sec := [(Short "SubtrahendLargerThanMinuend", (0, ExnStamp 0)); (Short "S", (1, TypeStamp "S" 0));
                         (Short "O", (0, TypeStamp "O" 0))] |}
                  [("minus", "x",
                   EFun "y"
                     (ELannot
                        (EMat (ELannot (EVar (Short "y")) [0])
                           [(Pcon (Some (Short "O")) [], ELannot (EVar (Short "x")) [0]);
                           (Pcon (Some (Short "S")) [Pvar "yp"],
                           ELannot
                             (EMat (ELannot (EVar (Short "x")) [0])
                                [(Pcon (Some (Short "O")) [],
                                 ELannot (ERaise (ELannot (ECon (Some (Short "SubtrahendLargerThanMinuend")) []) [0])) [0]);
                                (Pcon (Some (Short "S")) [Pvar "xp"],
                                ELannot
                                  (EApp Opapp
                                     [ELannot
                                        (EApp Opapp [ELannot (EVar (Short "minus")) [0]; ELannot (EVar (Short "xp")) [0]])
                                        [0]; ELannot (EVar (Short "yp")) [0]]) [0])]) [0])]) [0]))] "minus");
                (Short "mult",
                Recclosure
                  {|
                  sev := [(Short "plus",
                          Recclosure
                            {| sev := []; sec := [(Short "S", (1, TypeStamp "S" 0)); (Short "O", (0, TypeStamp "O" 0))] |}
                            [("plus", "x",
                             EFun "y"
                               (ELannot
                                  (EMat (ELannot (EVar (Short "x")) [0])
                                     [(Pcon (Some (Short "O")) [], ELannot (EVar (Short "y")) [0]);
                                     (Pcon (Some (Short "S")) [Pvar "xp"],
                                     ELannot
                                       (ECon (Some (Short "S"))
                                          [EApp Opapp
                                             [ELannot
                                                (EApp Opapp
                                                   [ELannot (EVar (Short "plus")) [0]; ELannot (EVar (Short "xp")) [0]]) [0];
                                             ELannot (EVar (Short "y")) [0]]]) [0])]) [0]))] "plus")];
                  sec := [(Short "S", (1, TypeStamp "S" 0)); (Short "O", (0, TypeStamp "O" 0))] |}
                  [("mult", "x",
                   EFun "y"
                     (ELannot
                        (EMat (ELannot (EVar (Short "x")) [0])
                           [(Pcon (Some (Short "O")) [], ELannot (ECon (Some (Short "O")) []) [0]);
                           (Pcon (Some (Short "S")) [Pvar "xp"],
                           ELannot
                             (ELet (Some "z")
                                (ELannot
                                   (EApp Opapp
                                      [ELannot
                                         (EApp Opapp [ELannot (EVar (Short "mult")) [0]; ELannot (EVar (Short "xp")) [0]])
                                         [0]; ELannot (EVar (Short "y")) [0]]) [0])
                                (ELannot
                                   (EApp Opapp
                                      [ELannot
                                         (EApp Opapp [ELannot (EVar (Short "plus")) [0]; ELannot (EVar (Short "y")) [0]])
                                         [0]; ELannot (EVar (Short "z")) [0]]) [0])) [0])]) [0]))] "mult");
                (Short "plus2",
                Recclosure
                  {|
                  sev := [(Short "succ",
                          Closure
                            {| sev := []; sec := [(Short "S", (1, TypeStamp "S" 0)); (Short "O", (0, TypeStamp "O" 0))] |}
                            "x" (ELannot (ECon (Some (Short "S")) [EVar (Short "x")]) [0]));
                         (Short "plus",
                         Recclosure
                           {| sev := []; sec := [(Short "S", (1, TypeStamp "S" 0)); (Short "O", (0, TypeStamp "O" 0))] |}
                           [("plus", "x",
                            EFun "y"
                              (ELannot
                                 (EMat (ELannot (EVar (Short "x")) [0])
                                    [(Pcon (Some (Short "O")) [], ELannot (EVar (Short "y")) [0]);
                                    (Pcon (Some (Short "S")) [Pvar "xp"],
                                    ELannot
                                      (ECon (Some (Short "S"))
                                         [EApp Opapp
                                            [ELannot
                                               (EApp Opapp
                                                  [ELannot (EVar (Short "plus")) [0]; ELannot (EVar (Short "xp")) [0]]) [0];
                                            ELannot (EVar (Short "y")) [0]]]) [0])]) [0]))] "plus")];
                  sec := [(Short "S", (1, TypeStamp "S" 0)); (Short "O", (0, TypeStamp "O" 0))] |}
                  [("plus2", "x",
                   EFun "y"
                     (ELannot
                        (EMat (ELannot (EVar (Short "x")) [0])
                           [(Pcon (Some (Short "O")) [], ELannot (EVar (Short "y")) [0]);
                           (Pcon (Some (Short "S")) [Pvar "xp"],
                           ELannot
                             (EApp Opapp
                                [ELannot (EVar (Short "succ")) [0];
                                ELannot
                                  (EApp Opapp
                                     [ELannot
                                        (EApp Opapp [ELannot (EVar (Short "plus")) [0]; ELannot (EVar (Short "xp")) [0]])
                                        [0]; ELannot (EVar (Short "y")) [0]]) [0]]) [0])]) [0]))] "plus2");
                (Short "plus",
                Recclosure {| sev := []; sec := [(Short "S", (1, TypeStamp "S" 0)); (Short "O", (0, TypeStamp "O" 0))] |}
                  [("plus", "x",
                   EFun "y"
                     (ELannot
                        (EMat (ELannot (EVar (Short "x")) [0])
                           [(Pcon (Some (Short "O")) [], ELannot (EVar (Short "y")) [0]);
                           (Pcon (Some (Short "S")) [Pvar "xp"],
                           ELannot
                             (ECon (Some (Short "S"))
                                [EApp Opapp
                                   [ELannot
                                      (EApp Opapp [ELannot (EVar (Short "plus")) [0]; ELannot (EVar (Short "xp")) [0]]) [0];
                                   ELannot (EVar (Short "y")) [0]]]) [0])]) [0]))] "plus");
                (Short "succ",
                Closure {| sev := []; sec := [(Short "S", (1, TypeStamp "S" 0)); (Short "O", (0, TypeStamp "O" 0))] |} "x"
                  (ELannot (ECon (Some (Short "S")) [EVar (Short "x")]) [0]))];
         sec := [(Short "SubtrahendLargerThanMinuend", (0, ExnStamp 0)); (Short "S", (1, TypeStamp "S" 0));
                (Short "O", (0, TypeStamp "O" 0))] |}.

Definition my_st := {| clock := 0; refs := []; ffi := init_ffi_st; next_type_stamp := 1; next_exn_stamp := 1 |}.

Inductive nat_rel_cake_nat (typestamp : nat) : nat -> val -> Prop :=
| zero_rel : nat_rel_cake_nat typestamp 0 (Conv (Some (TypeStamp "O" typestamp)) [])
| suc_rel  : forall (n : nat) (prev : val), nat_rel_cake_nat typestamp n prev -> nat_rel_cake_nat typestamp (S n) (Conv (Some (TypeStamp "S" typestamp)) [prev]).

Theorem plus_vs_cake_plus : forall (m n t : nat) (m_exp n_exp : exp) (m_val n_val m_n_val : val),
    (exists (mf : nat), evaluate_opt my_st my_env [m_exp] mf = (my_st, Rval [m_val])) ->
    (exists (nf : nat), evaluate_opt my_st my_env [n_exp] nf = (my_st, Rval [n_val])) ->
    nat_rel_cake_nat t m m_val ->
    nat_rel_cake_nat t n n_val ->
    (exists (mnf : nat), evaluate_opt my_st my_env [(EApp (Opapp) ((EApp (Opapp) ((EVar (Short ("plus"%string)))::m_exp::nil))::n_exp::nil))] mnf =
    (my_st, Rval [m_n_val])) ->
    nat_rel_cake_nat t (m+n) m_n_val.
Proof.
  intros m n t m_exp n_exp m_val n_val m_n_val.
Abort.


(* autogenerated from github.com/mit-pdos/gokv/fencing/loopclient *)
From Perennial.goose_lang Require Import prelude.
From Goose Require github_com.mit_pdos.gokv.fencing.client.

From Perennial.goose_lang Require Import ffi.grove_prelude.

Definition LoopOnKey: val :=
  rec: "LoopOnKey" "key" "config" :=
    let: "ck" := client.MakeClerk "config" in
    let: "lowerBound" := ref_to uint64T (client.Clerk__FetchAndIncrement "ck" "key") in
    Skip;;
    (for: (λ: <>, #true); (λ: <>, Skip) := λ: <>,
      let: "v" := client.Clerk__FetchAndIncrement "ck" "key" in
      control.impl.Assert ("v" > ![uint64T] "lowerBound");;
      (if: ("v" `rem` #1000 = #0)
      then
        (* log.Printf("reached %d >= %d", key, v) *)
        #()
      else #());;
      "lowerBound" <-[uint64T] "v";;
      Continue);;
    #().


Set Implicit Arguments.

Require Import util.
Require Import Le.
Require Import Plus.
Require Import Minus.
Require Import Lt.
Require Import Arith.
Require Import Recdef.
Require Import Bool_nat.
Require Import List.
Require Import monads.
Require Import Relation_Definitions.
Require Import monoid_monad_trans.
Require Import expec.
Require Import monoid_expec.
Require Import nat_seqs.
Require Import list_utils.
Require Import sums_and_averages.
Require qs_definitions.
Require qs_parts.
Require U.
Require Import sort_order.
Require Import indices.
Require Import qs_sound_cmps.
Require Import Fourier.
Require Import Rbase.
Require Import skip_list.
Require Import nat_below.
Require Vector.

Import qs_definitions.mon_nondet.

Section contents.

  Variables (ee: E) (ol: list ee) (i j: Index ee ol).

  Variable n: nat.
  Variable v: Vector.t (Index ee ol) (S n).
  Variable iltj: (i < j)%nat.

  Let flt x0 cr := filter (fun f: Index ee ol => unsum_bool (cmp_cmp (Ecmp (UE ee ol) f (vec.nth v x0)) cr)) (vec.remove v x0).

  Variable IH: forall (x0: natBelow (S n)) (cr: comparison) (b: nat),
    IndexSeq b (flt x0 cr) ->
    monoid_expec (U.ijcount i j) (qs (U.cmp (e:=ee) (ol:=ol)) U.pick (flt x0 cr)) <= 2 / INR (S (j - i)).

  Variables (b: nat) (is: IndexSeq b v).

  Lemma ndi: NoDup v.
    apply IndexSeq_NoDup with b.
    assumption.
  Qed.

  Variable iin: In i v.
  Variable jin: In j v.
  Variable pi: natBelow (S n).

  Lemma not_In_flt (k: Index ee ol) (dr: comparison) (H0: dr <> Ecmp (UE ee ol) k (vec.nth v pi)):
    ~ In k (flt pi dr).
  Proof with auto.
    unfold flt.
    intros.
    intro.
    destruct (proj1_conj (filter_In _ _ _) H). clear H.
    simpl in H0.
    simpl in H2.
    destruct (Ecmp ee (subscript k) (subscript (vec.nth v pi))); destruct dr; auto; simpl in H2; try discriminate...
  Qed.

  Lemma ndi_flt: forall x0 cr, NoDup (flt x0 cr).
  Proof.
    unfold flt.
    intros.
    apply NoDup_filter.
    apply (NoDup_SkipList ndi).
    cset (vec.SkipList_remove x0 v).
    assumption.
  Qed.

  Hint Immediate ndi_flt.

  Lemma partition_0: nb_val (vec.nth v pi) <> i -> nb_val (vec.nth v pi) <> j ->
    U.ijcount i j (map (fun i0: Index ee ol => U.unordered_nat_pair i0 (vec.nth v pi)) (vec.remove v pi)) = 0%nat.
  Proof.
    intros.
    apply (U.ijcount_0).
    intro.
    destruct (In_map_inv H1). clear H1.
    destruct H2.
    unfold U.unordered_nat_pair in H1.
    destruct (le_lt_dec x (vec.nth v pi)); inversion H1; auto.
  Qed.

  Hint Immediate U.hom_ijcount.
  Hint Immediate vec.remove_perm.

  Lemma pivot_not_In_flt cr: ~ In (vec.nth v pi) (flt pi cr).
  Proof with auto.
    intros H.
    pose proof ndi as H0.
    rewrite (Permutation.Permutation_sym (vec.List_Permutation (vec.remove_perm pi v))) in H0.
    inversion_clear H0...
    destruct (In_filter_inv _ _ _ H)...
  Qed.

  Lemma NoDup_comparisons (x: Index ee ol) (l: list (Index ee ol)):
    NoDup (x :: l) -> NoDup (map (fun i: Index ee ol => U.unordered_nat_pair i x) l).
  Proof with auto.
    intros.
    inversion_clear H.
    apply NoDup_map'...
    intros.
    unfold U.unordered_nat_pair.
    intro.
    apply H3.
    unfold Index in *.
    apply natBelow_unique.
    destruct (le_lt_dec x0 x); destruct (le_lt_dec y x); inversion H4; reflexivity.
  Qed.

  Lemma case_A: (vec.nth v pi < i)%nat ->
    INR (U.ijcount i j (map (fun i0: Index ee ol => U.unordered_nat_pair i0 (vec.nth v pi)) (vec.remove v pi))) +
    monoid_expec (U.ijcount i j)
      (foo <- @U.qs ee ol (flt pi Lt);
      bar <- @U.qs ee ol (flt pi Gt);
      ret  (foo ++ (vec.nth v pi :: flt pi Eq) ++ bar))
    <= 2 * / INR (S (j - i)).
  Proof with auto with real.
    intros.
    rewrite partition_0...
      Focus 2.
      intro.
      rewrite H0 in H.
      apply (lt_asym _ _ H iltj).
    rewrite Rplus_0_l.
    rewrite monoid_expec_plus... Focus 2. intros. repeat rewrite monoid_expec_plus...
    rewrite monoid_expec_plus...
    rewrite monoid_expec_ret...
    rewrite Rplus_0_r.
    rewrite sound_cmp_expec_0...
      Focus 2.
      left.
      apply not_In_flt...
      intro.
      apply (lt_asym _ _ H).
      symmetry in H0.
      apply (IndicesCorrect _ _ H0).
    rewrite Rplus_0_l.
    case_eq (Ecmp ee (subscript i) (subscript (vec.nth v pi))); intro.
        (* i in the Eq part *)
        unfold Rdiv.
        rewrite sound_cmp_expec_0...
        left.
        apply not_In_flt...
        simpl.
        simpl in H0.
        rewrite H0. intro. discriminate.
      (* in the Lt part, impossible *)
      elimtype False.
      apply (lt_irrefl i).
      apply lt_trans with (vec.nth v pi)...
      apply (IndicesCorrect i (vec.nth v pi))...
    (* i in the Gt part. recursive sorting of upper part: *)
    assert (IndexSeq b (vec.nth v pi :: vec.remove v pi)).
      apply IndexSeq_perm with v...
      cset (vec.List_Permutation (vec.remove_perm pi v))...
    apply (IH _ Gt (@InvIndexSeq_filterGt' ee ol (vec.nth v pi) (vec.remove v pi) b H1))...
  Qed.

  Lemma case_E: (j < vec.nth v pi)%nat ->
    INR (U.ijcount i j (map (fun i0: Index ee ol => U.unordered_nat_pair i0 (vec.nth v pi)) (vec.remove v pi))) +
    monoid_expec (U.ijcount i j)
      (foo <- @U.qs ee ol (flt pi Lt);
      bar <- @U.qs ee ol (flt pi Gt);
      ret (foo ++ (vec.nth v pi :: flt pi Eq) ++ bar))
    <= 2 * / INR (S (j - i)).
  Proof with auto with real.
    intros.
    rewrite partition_0...
      Focus 2.
      intro.
      cset (natBelow_unique _ _ H0).
      subst i.
      apply (lt_asym _ _ H iltj).
    rewrite Rplus_0_l.
    rewrite monoid_expec_plus...
      rewrite monoid_expec_plus...
      rewrite monoid_expec_ret...
      rewrite Rplus_0_r.
      rewrite (@sound_cmp_expec_0 ee ol i j (flt pi Gt))...
        Focus 2.
        right.
        apply not_In_flt.
        intro.
        apply (lt_asym _ _ H).
        cset (Ecmp_sym ee (subscript (vec.nth v pi)) (subscript j)).
        simpl in H0.
        simpl in H1.
        rewrite <- H0 in H1.
        simpl in H1.
        apply (IndicesCorrect _ _ H1).
      rewrite Rplus_0_r.
      case_eq (Ecmp ee (subscript j) (subscript (vec.nth v pi))); intro.
          (* j in the Eq part *)
          unfold Rdiv.
          rewrite sound_cmp_expec_0...
          right.
          apply not_In_flt...
          simpl.
          simpl in H0. simpl.
          rewrite H0. intro. discriminate.
        Focus 2.
        (* in the Gt part, impossible *)
        elimtype False.
        cset (Ecmp_sym ee (subscript (vec.nth v pi)) (subscript j)).
        rewrite H0 in H1.
        simpl in H1.
        apply (lt_asym _ _ H).
        apply (IndicesCorrect _ _ H1)...
      (* in the Lt part *)
      apply IH with b...
      unfold flt.
      assert (length (vec.nth v pi :: vec.remove v pi) = S n).
        simpl @length. rewrite vec.length...
      assert (IndexSeq b (vec.nth v pi :: vec.remove v pi)).
        apply IndexSeq_perm with v...
        apply (vec.List_Permutation (vec.remove_perm pi v)).
      cset (@IndexSeq_filterLt ee ol (vec.nth v pi) (S n) b (vec.nth v pi :: vec.remove v pi) H1 H2).
      simpl filter in H3.
      rewrite Ecmp_refl in H3...
    intros.
    repeat rewrite monoid_expec_plus...
  Qed.

  Lemma case_C: (i < vec.nth v pi)%nat -> (vec.nth v pi < j)%nat ->
    INR (U.ijcount i j (map (fun i0: Index ee ol => U.unordered_nat_pair i0 (vec.nth v pi)) (vec.remove v pi))) +
    monoid_expec (U.ijcount i j)
      (foo <- @U.qs ee ol (flt pi Lt);
      bar <- @U.qs ee ol (flt pi Gt);
      ret (foo ++ (vec.nth v pi :: flt pi Eq) ++ bar))
    = 0.
  Proof with auto with real.
  intros.
    rewrite partition_0...
    rewrite Rplus_0_l.
    unfold U.M.
    rewrite monoid_expec_bind_0_r...
      apply sound_cmp_expec_0...
      right.
      apply not_In_flt.
      intro.
      apply (lt_asym _ _ H0).
      symmetry in H1.
      apply (IndicesCorrect _ _ H1).
    intros.
    rewrite monoid_expec_plus...
    rewrite (monoid_expec_ret (U.hom_ijcount i j)).
    rewrite Rplus_0_r.
    apply sound_cmp_expec_0...
    left.
    apply not_In_flt.
    intro.
    cset (Ecmp_sym ee (subscript (vec.nth v pi)) (subscript i)).
    simpl in H1. simpl in H2.
    rewrite <- H1 in H2.
    simpl in H2.
    apply (lt_asym _ _ H).
    apply (IndicesCorrect _ _ H2).
  Qed.

  Lemma case_BD: (i = vec.nth v pi \/ j = vec.nth v pi) ->
    INR (U.ijcount i j (map (fun i0: Index ee ol => U.unordered_nat_pair i0 (vec.nth v pi)) (vec.remove v pi))) +
    monoid_expec (U.ijcount i j)
      (foo <- @U.qs ee ol (flt pi Lt);
      bar <- @U.qs ee ol (flt pi Gt);
      ret (foo ++ (vec.nth v pi :: flt pi Eq) ++ bar))
    <= 1.
  Proof with auto with real.
    intros.
    rewrite (monoid_expec_bind_0_r (U.hom_ijcount i j)).
      rewrite sound_cmp_expec_0...
        rewrite Rplus_0_r.
        rewrite U.ijcount_eq_count.
        replace 1 with (INR 1)...
        apply le_INR.
        apply eq_count_NoDup.
        apply NoDup_comparisons.
        rewrite (vec.List_Permutation (vec.remove_perm pi v)).
        apply IndexSeq_NoDup with b...
      destruct H; subst; [left | right]; apply pivot_not_In_flt.
    intros.
    unfold U.M.
    rewrite monoid_expec_plus...
    rewrite (monoid_expec_ret (U.hom_ijcount i j)).
    rewrite sound_cmp_expec_0...
    destruct H; subst; [left | right]; apply pivot_not_In_flt.
  Qed.

End contents.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall P Q A B C Dprime Pprime Cprime Dprimeprime Pprimeprime Z Zprime T : Universe, ((wd_ P Q /\ (wd_ T Z /\ (wd_ T Zprime /\ (wd_ T Pprimeprime /\ (wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ Zprime Z /\ (wd_ B T /\ (wd_ Cprime Pprimeprime /\ (wd_ B Pprime /\ (wd_ B Cprime /\ (wd_ Dprimeprime Cprime /\ (wd_ Dprime B /\ (wd_ Zprime B /\ (wd_ Z B /\ (wd_ B Pprimeprime /\ (wd_ B Dprimeprime /\ (wd_ Cprime C /\ (wd_ A Dprime /\ (wd_ Pprime Cprime /\ (col_ A B Zprime /\ (col_ Z B T /\ (col_ B Pprimeprime T /\ (col_ Zprime T Z /\ (col_ B C Z /\ (col_ Cprime Dprimeprime Pprimeprime /\ (col_ B Cprime A /\ col_ B Dprime Pprime)))))))))))))))))))))))))))) -> col_ A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.


(* Cyclone Semantics using TLC/LN in Coq Version 4 *)
(* "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".   Daniel Grossman, August 2003 *)
(* Brian Milnes 2016 *)
(* Lemmas for get. *)

Set Implicit Arguments.
Require Import TLC.LibEnv LibVarPathEnv Cyclone_LN_Tactics Cyclone_Fset_Lemmas.
Require Import Cyclone_Admit_Environment.
Close Scope list_scope.
Import LibEnvNotations.
Import LVPE.LibVarPathEnvNotations.

Ltac get_empty:=
  match goal with
  | H: get _ empty = Some _ |- _ =>
    rewrite get_empty in H; inversion H
  end.

Ltac lvpe_get_empty:=
  match goal with
  | H: LVPE.V.get _ empty = Some _ |- _ =>
    rewrite LVPE.get_empty in H; inversion H
end.

Ltac simpl_get ::=
  (* idtac "simpl_get";*)
  trace_goal;
  timeout 2
  repeat
    match goal with
  | |- context [get ?a empty]           => trace_goal; rewrite~ get_empty
  | |- context [get ?a empty]           => trace_goal; rewrite~ get_empty
  | |- context [get ?a empty]           => trace_goal; rewrite~ get_empty
  | |- context [get ?a (_ & (_ ~ _)) ]      => trace_goal;
    rewrite~ get_push; try repeat case_var~

  | |- context [get ?a ((?b ~ _) & _)] => trace_goal;
    rewrite~ get_concat; try repeat case_var~

  | |- context [get ?a _ = None] => trace_goal;
   apply* get_none

  | H: context[get _ empty = Some _] |- _ =>
    rewrite get_empty in H; inversion H
end.

Lemma get_fv_delta:
  forall v d k,
    get v d = Some k ->
    \{v} \c fv_delta d.
Proof.
  intros.
  unfold fv_delta.
  induction d using env_ind.
  rewrite get_empty in H.
  inversion H.
  rewrite get_push in H.
  case_var.
  inversion H.
  subst.
  rewrite dom_push.
  fset.
  apply IHd in H.
  rewrite dom_push.
  apply* subset_weakening.
Qed.
Ltac get_fv_delta :=
  match goal with
  | H: get ?v ?d = Some ?k' |- \{?v} \c fv_delta ?d =>
    apply get_fv_delta with (k:= k'); assumption; auto with fset
end.
Hint Extern 1 (\{_} \c fv_delta _) => get_fv_delta.
Hint Extern 1 (T.fv _ \c fv_delta _) => simpl; get_fv_delta.

Lemma get_dom:
  forall A alpha (d : env A)  k,
    get alpha d = Some k ->
    \{alpha} \c dom d.
Proof.
  intros.
  induction d using env_ind.
  rewrite get_empty in H.
  inversion H.
  destruct (classicT(alpha = x)).
  subst.
  rewrite dom_push.
  fset.
  rewrite get_push in H.
  rewrite* If_r in H.
  apply IHd in H.
  rewrite dom_push.
  apply* subset_weakening.
Qed.
Ltac get_dom :=
  match goal with
  | H: get ?a ?d = Some ?k'
  |- \{?a} \c dom ?d =>
    apply get_dom with (k:= k')
  end.
Hint Extern 1 (\{_} \c dom _) => get_dom.

(* Arthur's binds theorems redone in get. *)

Section GetProperties.
Variable A B' : Type.
Implicit Types E F : env A.
Implicit Types x : var.
Implicit Types v : A.

(** Constructor forms *)

Lemma get_empty_inv : forall x v,
  get x empty = Some v -> False.
Proof using.
  introv H. rewrite get_empty in H. false.
Qed.

Lemma get_single_eq : forall x v,
  get x (x ~ v) = Some v.
Proof using.
  intros.  rewrite get_single. case_if~.
Qed.

Lemma get_single_inv : forall x1 x2 v1 v2,
  get x1 (x2 ~ v2) = Some v1 ->
  x1 = x2 /\ v1 = v2.
Proof using.
   introv H. rewrite get_single in H.
  case_if; inversions~ H.
Qed.

Lemma get_push_inv : forall x1 v1 x2 v2 E,
  get x1 (E & x2 ~ v2) = Some v1 ->
     (x1 = x2 /\ v1 = v2)
  \/ (x1 <> x2 /\ get x1 E = Some v1).
Proof using.
  introv H.  rewrite get_push in H. case_if.
  inverts~ H. auto.
Qed.

Lemma get_push_eq : forall x v E,
  get x (E & x ~ v) = Some v.
Proof using. intros.  rewrite get_push. case_if~. Qed.

Lemma get_push_eq_inv : forall x v1 v2 E,
  get x (E & x ~ v2) = Some v1 -> v1 = v2.
Proof using.
  introv H. forwards [|]: get_push_inv H. autos*. intros [? _]. false.
Qed.

Lemma get_push_neq_inv : forall x1 x2 v1 v2 E,
  get x1 (E & x2 ~ v2) = Some v1 -> x1 <> x2 -> get x1 E = Some v1.
Proof using.
  introv H. forwards [|]: get_push_inv H.
  intros [? ?] ?. false. autos*.
Qed.

Lemma get_tail : forall x v E,
  get x (E & x ~ v) = Some v.
Proof using. intros. rewrite get_push. cases_if~. Qed.

Lemma get_push_neq : forall x1 x2 v1 v2 E,
  get x1 E = Some v1 -> x1 <> x2 -> get x1 (E & x2 ~ v2) = Some v1.
Proof using.
  introv H N.  rewrite get_push. case_if~.
Qed.

Lemma get_concat_inv : forall x v E1 E2,
  get x (E1 & E2) = Some v ->
     (get x E2 = Some v)
  \/ (x # E2 /\ get x E1 = Some v).
Proof using.
  introv H. induction E2 using env_ind.
  rewrite~ concat_empty_r in H.
  rewrite concat_assoc in H.
   forwards [[? ?]|[? M]]: get_push_inv H.
     subst. left. apply get_tail.
     forwards [?|[? ?]]: IHE2 M.
       left. applys~ get_push_neq.
       right.
       auto.
Qed.

(* Typing env vs list issues.
Lemma get_map : forall x v (f : A -> B) E,
  get x E = Some v -> get x (map f E) = Some (f v).
Proof using.
  introv H.  rew_env_defs.
  induction E as [|[x' v'] E']; simpls.
  false.
  cases_if~. inverts~ H.
Qed.
*)

Lemma get_func : forall x v1 v2 E,
  get x E = Some v1 -> get x E = Some v2 -> v1 = v2.
Proof using.
  introv H1 H2.
  induction E as [|E' x' v'] using env_ind.
  rewrite get_empty in H1. false.
  rewrite get_push in H1,H2. case_if~.
   inverts H1. inverts~ H2.
Qed.

Lemma get_fresh_inv : forall x v E,
  get x E = Some v -> x # E -> False.
Proof using.
  introv H F.
  induction E as [|E' x' v'] using env_ind.
  rewrite get_empty in H. false.
  rewrite get_push in H. case_if~. subst.
   simpl_dom; notin_false.
Qed.

(** Derived forms *)

Lemma get_single_eq_inv : forall x v1 v2,
  get x (x ~ v2) = Some v1 ->
  v1 = v2.
Proof using.
  introv H. rewrite get_single in H.
  case_if. inverts~ H.
Qed.

Lemma get_concat_left : forall x v E1 E2,
  get x E1 = Some v ->
  x # E2 ->
  get x (E1 & E2) = Some v.
Proof using.
  introv H F. induction E2 using env_ind.
  rewrite~ concat_empty_r.
  rewrite concat_assoc.
  applys~ get_push_neq.
  subst.
  simpl_dom.
  apply notin_union in F.
  inversion F.
  apply notin_singleton_r in H0; auto.
Qed.

Lemma get_concat_left_ok : forall x v E1 E2,
  ok (E1 & E2) ->
  get x E1 = Some v ->
  get x (E1 & E2) = Some v.
Proof using.
  introv O H. induction E2 using env_ind.
  rewrite~ concat_empty_r.
  rewrite concat_assoc in O|-*. lets [_ ?]: ok_push_inv O.
  applys~ get_push_neq. subst.
  intro_subst.
  applys~ get_fresh_inv H.
Qed.

Lemma get_concat_left_inv : forall x v E1 E2,
  get x (E1 & E2) = Some v ->
  x # E2 ->
  get x E1 = Some v.
Proof using.
  introv H F. lets~ [M|[? ?]]: get_concat_inv H.
    false. applys~ get_fresh_inv M.
Qed.

Lemma get_concat_right : forall x v E1 E2,
  get x E2 = Some v ->
  get x (E1 & E2) = Some v.
Proof using.
  introv H. induction E2 using env_ind.
  false. apply get_empty_inv with (x:=x) (v:=v); auto.
  rewrite concat_assoc. lets [[? ?]|[? ?]]: get_push_inv H.
    subst. applys get_tail.
    applys* get_push_neq.
Qed.

Lemma get_concat_right_inv : forall x v E1 E2,
  get x (E1 & E2) = Some v ->
  x # E1 ->
  get x E2 = Some v.
Proof using.
  introv H F. lets~ [?|[? M]]: get_concat_inv H.
    false. applys~ get_fresh_inv M.
Qed.

Lemma get_middle_eq : forall x E1 E2 v,
  x # E2 ->
  get x (E1 & x ~ v & E2) = Some v.
Proof using.
  introv F. applys~ get_concat_left.
Qed.

(** Metatheory proof forms *)

(** Interaction between binds and the insertion of bindings.
  In theory we don't need this lemma since it would suffice
  to use the get_cases tactics, but since weakening is a
  very common operation we provide a lemma for it. *)

Lemma get_weaken : forall x a E F G,
  get x (E & G) = Some a -> ok (E & F & G) ->
  get x (E & F & G) = Some a.
Proof using.
  introv H O. lets [?|[? ?]]: get_concat_inv H.
    applys~ get_concat_right.
    applys~ get_concat_left. applys~ get_concat_left_ok.
Qed.

Lemma get_remove : forall E2 E1 E3 x v,
  get x (E1 & E2 & E3) = Some v ->
  x # E2 ->
  get x (E1 & E3) = Some v.
Proof using.
  introv H F. lets [?|[? M]]: get_concat_inv H.
    applys~ get_concat_right.
    forwards: get_concat_left_inv M; auto.
    applys~ get_concat_left.
Qed.

Lemma get_subst : forall x2 v2 x1 v1 E1 E2,
  get x1 (E1 & x2 ~ v2 & E2) = Some v1 ->
  x1 <> x2 ->
  get x1 (E1 & E2) = Some v1.
Proof using.
  introv H N.
  applys~ get_remove H.
Qed.

Lemma get_middle_eq_inv : forall x E1 E2 v1 v2,
  get x (E1 & x ~ v2 & E2) = Some v1 ->
  ok (E1 & x ~ v2 & E2) ->
  v1 = v2.
Proof using.
  introv H O. lets [? ?]: ok_middle_inv O.
  forwards~ M: get_concat_left_inv H.
  applys~ get_push_eq_inv M.
Qed.

Lemma get_middle_inv : forall x1 v1 x2 v2 E1 E2,
  get x1 (E1 & x2 ~ v2 & E2) = Some v1 ->
     (get x1 E2 = Some v1)
  \/ (x1 # E2 /\ x1 = x2 /\ v1 = v2)
  \/ (x1 # E2 /\ x1 <> x2 /\ get x1 E1 = Some v1).
Proof using.
  introv H. lets [?|[? M]]: (get_concat_inv H).
    left~.
    right. lets [N|[? N]]: (get_concat_inv M).
      lets [? ?]: (get_single_inv N). subst~.
      right. simpl_dom. split~.
Qed.

Lemma get_not_middle_inv : forall x v E1 E2 E3,
  get x (E1 & E2 & E3) = Some v ->
  x # E2 ->
     (get x E3 = Some v)
  \/ (x # E3 /\ get x E1 = Some v).
Proof using.
  introv H F. lets [?|[? M]]: (get_concat_inv H).
    left~.
    right. forwards~ N: (get_concat_left_inv M).
Qed.

Lemma fv_in_values_get : forall y fv x v E,
  get x E = Some v -> y \notin fv_in_values fv E -> y \notin fv v.
Proof using.
  unfold fv_in_values. introv H.
  induction E using env_ind; introv M.
  false. apply get_empty_inv with (x:= x) (v:= v); auto.
  rewrite values_def in M,IHE.
  rewrite concat_def, single_def in M. rew_list in M. simpl in M.
  lets [[? ?]|[? ?]]: (get_push_inv H); subst~.
Qed.

End GetProperties.

Lemma ok_contradict:
  forall A (d : env A) alpha0 k' k,
  ok (d & alpha0 ~ k') ->
  get alpha0 d  = Some k ->
  False.
Proof.
  introv okd getd.
  induction d using env_ind.
  rewrite get_empty in getd.
  inversion getd.
  destruct(classicT(x = alpha0)); subst.
  apply ok_push_inv  in okd.
  inversion okd.
  unfolds in H0.
  unfolds in H0.
  rewrite dom_push in H0.
  contradict H0.
  rewrite in_union.
  left.
  apply in_singleton_self.
  applys IHd; auto.
  rewrite get_push in getd.
  auto.
Qed.

Lemma get_strength:
  forall A alpha (d : env A) k,
    get alpha d = Some k ->
    forall alpha0 k',
      ok (d & alpha0 ~ k') ->
      get alpha (d & alpha0 ~ k') = Some k.
Proof.
  intros.
  inversion H0.
  apply empty_push_inv in H2.
  inversion H2.
  rewrite get_push.
  case_var*.
  apply eq_inversion_env in H1.
  inversions H1.
  inversions H5.
  apply ok_contradict with (k:= k) in H0; auto.
  inversion H0.
  apply eq_inversion_env in H1.
  inversions* H1.
Qed.
Ltac get_strength:=
  match goal with
  | H: get ?alpha ?d = Some ?k |-
    get ?alpha (?d & _ ~ _) = Some ?k
    => apply* get_strength
end.
Hint Extern 2 (get _ (_ & _ ~ _) = Some _) => try get_strength.

Lemma get_middle_strength:
  forall A alpha0 (d : env A) alpha k d' k',
    alpha0 <> alpha ->
    get alpha0 (d & alpha ~ k & d') = Some k' ->
    get alpha0 (d & d') = Some k'.
Admitted.

Lemma get_middle_k:
  forall A (d : env A) alpha k d',
    ok (d & alpha ~ k & d') ->
    forall k',
      get alpha (d & alpha ~ k & d') = Some k' ->
      k = k'.
Admitted.


(* Copyright (c) 2012-2015, Robbert Krebbers. *)
(* This file is distributed under the terms of the BSD license. *)
Require Export memory_separation expression_eval.

Lemma expr_eval_subseteq `{EnvSpec K} Γ Δ ρ m1 m2 e ν τlr :
  ✓ Γ → ✓{Γ,Δ} m1 → ✓{Δ}* ρ → (Γ,Δ,ρ.*2) ⊢ e : τlr →
  ⟦ e ⟧ Γ ρ m1 = Some ν → m1 ⊆ m2 → ⟦ e ⟧ Γ ρ m2 = Some ν.
Proof.
  intros. eapply expr_eval_weaken; eauto using cmap_subseteq_index_alive,
    mem_lookup_subseteq, mem_forced_subseteq.
Qed.


From Coq Require Import Strings.String Logic.FunctionalExtensionality.
From Rupicola.Lib Require Import Core.

Set Implicit Arguments.

Class Monad (M: Type -> Type) :=
  { mret {A} : A -> M A;
    mbind {A B} : M A -> (A -> M B) -> M B;
    mbindn {A B} (vars: list string) (ma: M A) (kA: A -> M B) : M B :=
      mbind ma kA;

    mbind_mret {A} (ma: M A) : mbind ma mret = ma;
    mret_mbind {A B} a (k: A -> M B) : mbind (mret a) k = k a;
    mbind_mbind {A B C} ma (ka: A -> M B) (kb: B -> M C) :
      mbind (mbind ma ka) kb = mbind ma (fun a => mbind (ka a) kb);

    mbindn_mret {A} vars (ma: M A) : mbindn vars ma mret = ma :=
      mbind_mret _;
    mret_mbindn {A B} vars a (k: A -> M B) : mbindn vars (mret a) k = nlet vars a k :=
      mret_mbind _ _;
    mbindn_mbindn {A B C} varsa varsb ma (ka: A -> M B) (kb: B -> M C) :
      mbindn varsb (mbindn varsa ma ka) kb = mbindn varsa ma (fun a => mbindn varsb (ka a) kb) :=
      mbind_mbind _ _ _;
  }.

Arguments mret : simpl never.
Arguments mbind : simpl never.
Arguments mbindn : simpl never.

Module Free.
  Section Free.
    Context {F: Type -> Type}.

    Inductive M (A: Type) : Type :=
    | Pure (a: A) : M A
    | Impure X (f: F X) (k: X -> M A) : M A.

    Definition Call {A} (f: F A) := Impure f (@Pure _).

    Definition ret {A} (a: A) : M A := Pure a.

    Fixpoint bind {A B} (f: M A) (kA: A -> M B) : M B :=
      match f with
      | Pure a => kA a
      | Impure f kX => Impure f (fun x => bind (kX x) kA)
      end.

    Ltac s :=
      simpl; eauto using f_equal, FunctionalExtensionality.functional_extensionality.

    Global Program Instance MonadM : Monad M :=
      {| mret := @ret;
         mbind := @bind |}.
    Obligation 1. Proof. induction ma; s. Qed.
    Obligation 3. Proof. induction ma; s. Qed.

    Context {M': Type -> Type} {MM': Monad M'}.
    Context (interpF: forall {A}, F A -> M' A).

    Fixpoint interp {A: Type} (f: M A) : M' A :=
      match f with
      | Pure a => mret a
      | Impure f k => mbind (@interpF _ f) (fun x => interp (k x))
      end.

    Lemma interp_mbind {A B} (ma: M A) (k: A -> M B) :
      mbind (M := M') (interp ma) (fun a => interp (k a)) =
      interp (mbind (M := M) ma k).
    Proof.
      induction ma; simpl; intros.
      all: repeat rewrite ?mret_mbind, ?mbind_mret, ?mbind_mbind; s.
    Qed.

    Lemma interp_mbindn {A B} vars (ma: M A) (k: A -> M B) :
      mbindn vars (M := M') (interp ma) (fun a => interp (k a)) =
      interp (mbindn vars (M := M) ma k).
    Proof. apply interp_mbind. Qed.
  End Free.
End Free.

#[export] Hint Extern 2 (IsRupicolaBinding (mbindn (A := ?A) ?vars _ _)) => exact (RupicolaBinding A vars) : typeclass_instances.

#[global]
Hint Rewrite @mbindn_mbindn @mret_mbindn : compiler_cleanup.


Require Import VST.floyd.proofauto.
Require Import VST.progs.nest2.

#[export] Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Local Open Scope logic.

Definition t_struct_b := Tstruct _b noattr.

Definition get_spec :=
 DECLARE _get
  WITH v : reptype' t_struct_b, gv: globals
  PRE  []
        PROP ()
        PARAMS() GLOBALS (gv)
        SEP(data_at Ews t_struct_b (repinj _ v) (gv _p))
  POST [ tint ]
         PROP()
         RETURN (Vint (snd (snd v)))
         SEP (data_at Ews t_struct_b (repinj _ v) (gv _p)).

Definition get_spec' :=
 DECLARE _get
  WITH v : (int * (float * int))%type, gv: globals
  PRE  []
        PROP ()
        PARAMS() GLOBALS (gv)
        SEP(data_at Ews t_struct_b (repinj t_struct_b v) (gv _p))
  POST [ tint ]
         PROP()
         RETURN (Vint (snd (snd v)))
         SEP (data_at Ews t_struct_b (repinj t_struct_b v) (gv _p)).

Definition update22 (i: int) (v: reptype' t_struct_b) : reptype' t_struct_b :=
   (fst v, (fst (snd v), i)).

Definition set_spec :=
 DECLARE _set
  WITH i : int, v : reptype' t_struct_b, gv: globals
  PRE  [ tint ]
         PROP  ()
         PARAMS (Vint i) GLOBALS (gv)
         SEP   (data_at Ews t_struct_b (repinj _ v) (gv _p))
  POST [ tvoid ]
         PROP() RETURN()
        SEP(data_at Ews t_struct_b (repinj _ (update22 i v)) (gv _p)).

Definition Gprog : funspecs :=   ltac:(with_library prog [get_spec; set_spec]).

Lemma body_get:  semax_body Vprog Gprog f_get get_spec.
Proof.
start_function.
simpl in v.
unfold_repinj.
Time forward. (* 5.989 sec  -> 2.6 -> 1.5 *)
Time forward. (* 11.1118 sec -> 7.5 *)
Time Qed.

Lemma body_get':  semax_body Vprog Gprog f_get get_spec'.
Proof.
start_function.
simpl in v.
unfold_repinj.
Time forward. (* 5.989 sec  -> 2.6*)
Time forward. (* 11.1118 sec -> 7.5 *)
Qed.

Lemma body_set:  semax_body Vprog Gprog f_set set_spec.
Proof.
 start_function.
simpl in v.
(*destruct v as [a [b c]]; simpl in *. *)
unfold_repinj.
Time forward. (* 1.23 sec *)
entailer!!.
Time Qed.  (*  28 sec -> 3.45 sec *)


From mathcomp Require Import ssreflect seq ssrint ssrfun.
From Coq.Strings Require Import Ascii String.
Require Import Coq.Program.Basics.

Require Import Syntax Common State Types State Memory.

Require Import Operational.

Open Scope string.

Definition iptr b o := AnyPtr Int64 $ Goodptr Int64 b o.

Definition testfun instr := mk_fun 0 "main" nil instr.
Definition tproc pid  cont : proc_state := mk_proc_state pid nil nil nil nil nil nil cont nil nil nil.
Definition teststate instr := MGood  [:: tproc 0 nil ; tproc 1 [:: instr ] ]
                                     [:: testfun instr].
Definition empty2 instr := MGood [:: tproc 0 nil ; tproc 1 nil ] [:: testfun instr].

Theorem test_skip:  ss_reduce (teststate Skip) (empty2 Skip).
    by eapply ( ss_skip _ _ 1). Qed.

Import Relation_Operators.

Theorem ss_implies_bs s s': ss_reduce s s' -> bs_reduce s s'.
  move=> H.
  eapply rt1n_trans.
  eapply H.
  eapply rt1n_refl.
Qed.

Theorem test_skip_bs: bs_reduce (teststate Skip) (empty2 Skip).
  by eapply ss_implies_bs ; eapply (ss_skip _ _ 1).
Qed.

Definition reduce_interp s := ss_reduce s (interpret_ss s 1).

(*** TESTS ***)

Theorem test_skip': reduce_interp (teststate Skip).
  by eapply (ss_skip _ _ 1).
Qed.

Theorem test_alloc_anon: reduce_interp (teststate (Alloc Stack Int64 None 1)).
    by eapply (ss_alloc_anon _ _ 1).
Qed.

Theorem test_alloc: reduce_interp (teststate (Alloc Stack Int64 (Some "hey") 1)).
    by eapply (ss_alloc _ _ 1).
Qed.

Definition prog_if_true := If (Lit (ValueI64 (Posz 4))) (Alloc Stack Int64 None 1) (Alloc Stack Int64 None 2).

Theorem test_if_true: reduce_interp (teststate prog_if_true).
    by eapply (ss_if_true _ _ 1).
Qed.

Compute interpret_ss (teststate prog_if_true) 1.

Definition prog_if_false := If (Lit (ValueI8 (Posz 0))) (Alloc Stack Int64 None 1) (Alloc Stack Int64 None 2).

Theorem test_if_false: reduce_interp (teststate prog_if_false).
    by eapply (ss_if_false _ _ 1).
Qed.

Definition prog_while_true := While (Lit (ValueI64 (Posz 1))) (Alloc Stack Int64 None 0).
Definition prog_while_false := While (Lit (ValueI64 (Posz 0))) (Alloc Stack Int64 None 0).

Theorem test_while_true: reduce_interp (teststate prog_while_true).
    by eapply (ss_while_true _ _ 1).
Qed.

Theorem test_while_false: reduce_interp (teststate prog_while_false).
    by eapply (ss_while_false _ _ 1).
Qed.

Theorem test_codeblock: reduce_interp (teststate $ CodeBlock [:: Alloc Stack Int64 None 0 ] ).
    by eapply (ss_codeblock _ _ 1).
Qed.

Definition state_with_mem := interpret_ss (teststate $ Alloc Stack Int64 (Some "x") 1) 1.

Definition mix_statement ms pid stat := ms_mod_proc pid (ps_mod_cont (cons stat)) ms.

Compute  mix_statement state_with_mem 1 $ Assign (Lit (ValuePtr (AnyPtr Int64 (Goodptr Int64 0 0)))) (Lit (ValueI64 (Posz 11))).
Compute interpret_ss  ( mix_statement state_with_mem 1 $ Assign (Lit (ValuePtr (AnyPtr Int64 (Goodptr Int64 0 0)))) (Lit (ValueI64 (Posz 11)))) 1.

Theorem test_assign: reduce_interp (mix_statement state_with_mem 1 $ Assign (Lit (ValuePtr (AnyPtr Int64 (Goodptr Int64 0 0)))) (Lit (ValueI64 (Posz 11)))).
  by eapply (ss_assign _ _ 1).
Qed.

Theorem test_assign_type_conv: reduce_interp (mix_statement state_with_mem 1 $ Assign (Lit (ValuePtr (AnyPtr Int32 (Goodptr _ 0 0)))) (Lit (ValueI64 (Posz 11)))).
  by eapply (ss_assign _ _ 1).
Qed.

Definition simple_state pid vars mem cont := mk_proc_state pid vars nil nil nil nil mem cont nil nil nil.

Definition call_state := MGood [::
                                  simple_state 0 nil nil nil;
                                 simple_state 1 nil nil [:: Call "f" nil]
                               ] [:: mk_fun 0 "main" nil Skip;
                                   mk_fun 1 "f" nil $ Alloc Stack Int64 (Some "x") 1 ].

Theorem test_call: reduce_interp call_state.
   by eapply (ss_call _ _ 1).
Qed.

Theorem test_enter: reduce_interp (teststate Enter).
 by eapply (ss_enter _ _ 1).
Qed.

Definition LocVarBlock id t v := mk_block Stack id (size_of t) t [:: v].
Definition LocVarBlockInt64 id v := LocVarBlock id Int64 (ValueI64 v).

Definition test_leave_state := MGood
                                 [::
                                    simple_state 0 nil nil nil;
                                   simple_state 1 [:: [:: declare_var "x" Int64 0 ] ; [:: declare_var "y" Int32 1 ] ]
                                                [:: LocVarBlockInt64 0 6; LocVarBlockInt64 1 4]
                                                    [:: Leave]
                                 ] [:: ].
Compute interpret_ss test_leave_state 1.

Theorem test_leave: reduce_interp test_leave_state.
    by  eapply (ss_leave _ _ 1).
Qed.

Definition pushreg_state := MGood [::
                                     simple_state 0 nil nil nil;
                                    simple_state 1 nil [:: LocVarBlockInt64 0 6 ]
                                                 [::
                                                    BspPushReg
                                                    (Lit (ValuePtr (AnyPtr Int32 (Goodptr _ 0 0))))
                                                    (Lit (ValueI64 (Posz (size_of Int64)))) ]
                                  ]
                                  nil.

Theorem test_pushreg: reduce_interp pushreg_state.
    by eapply (ss_bsp_push _ _ 1).
Qed.

Compute interpret_ss pushreg_state 1.

Definition popreg_state := MGood [::
                                     simple_state 0 nil nil nil;
                                    simple_state 1 nil [:: LocVarBlockInt64 0 6 ]
                                                 [::
                                                    BspPopReg
                                                    (Lit (ValuePtr (AnyPtr Int32 (Goodptr _ 0 0)))) ]
                                  ]
                                  nil.

Theorem test_popreg: reduce_interp popreg_state.
    by eapply (ss_bsp_pop _ _ 1).
Qed.

Definition IntPtr b o:=  AnyPtr Int64 ( Goodptr _ b o).
Definition VIntPtr b o := ValuePtr $ IntPtr b o.

Theorem test_get: reduce_interp ( teststate $
                                             BspGet
                                             (Lit $ ValueI64 0)
                                             (Lit $ VIntPtr 0 0)
                                             (Lit $ ValueI64 0)
                                             (Lit $ VIntPtr 0 0)
                                             (Lit $ ValueI64 (Posz 0))).
    by  eapply (ss_bsp_get _ _ 1).
Qed.

Notation "{* b o : t }" := (AnyPtr t (Goodptr t b o)) (at level 55, no associativity).

Definition test_put_state := MGood
                                     [::
                                        mk_proc_state
                                        0
                                        nil
                                        nil
                                        [:: nil ; nil ]
                                        nil
                                        nil
                                        [:: LocVarBlockInt64 0 10; LocVarBlockInt64 1 11]
                                        nil
                                        [:: ( IntPtr 0 0, 8 )]
                                        nil
                                        nil ;
                                       mk_proc_state
                                         1
                                         nil
                                         nil
                                         [:: nil; nil]
                                         nil
                                         nil
                                         [:: LocVarBlockInt64 0 4; LocVarBlockInt64 1 5; LocVarBlockInt64 2 6 ]
                                         [:: BspPut (Lit $ ValueI64 0)
                                            (Lit $ VIntPtr 2 0)
                                            (Lit $ ValueI64 0)
                                            (Lit $ VIntPtr 1 0)
                                            (Lit $ ValueI64 8) ]

                                         [:: ( IntPtr 2 0, 8 )]

                                         nil
                                         nil ] nil.

Compute interpret_ss test_put_state 1.

Definition test_put: reduce_interp test_put_state.
  by eapply (ss_bsp_put _ _ 1).
Qed.

Theorem test_sync_end1 : ss_reduce (MGood [::
                                             simple_state 0 nil nil  [:: BspSync] ;
                                            simple_state 1 nil nil [:: BspSync]
                                          ]
                                          nil)
                                   (MGood [::
                                             simple_state 0 nil nil  nil ;
                                            simple_state 1 nil nil nil
                                          ]
                                          nil).
by  eapply (ss_sync_end ).
Qed.
(*
Definition test_sync_pop_state :=
  ms_mod_proc 1 (
                ps_mod_queue_pop (cons $ Pop $  IntPtr 0 0 )
c                                 \o ps_mod_reg_loc ( cons ( IntPtr 0 0 , 8) )
                                 \o ps_mod_cont (cons BspSync)
                                 \o ps_mod_mem (const
              )
$  empty_state 2.*)

Definition test_sync_pop_state := MGood [::
                                              mk_proc_state
                                                0
                                                nil
                                                nil
                                                nil
                                                [:: Pop $ IntPtr 0 0]
                                                nil
                                                [:: LocVarBlockInt64 0 10; LocVarBlockInt64 1 11]
                                                [:: BspSync]
                                                [:: ( IntPtr 0 0, 8 )]
                                                nil
                                                nil ;
                                             mk_proc_state
                                                1
                                                nil
                                                nil
                                                nil
                                                [:: Pop $ IntPtr 1 0]
                                                nil
                                                [:: LocVarBlockInt64 0 11; LocVarBlockInt64 1 4; LocVarBlockInt64 2 13 ]
                                                [:: BspSync]
                                                [:: ( IntPtr 1 0, 8 )]
                                                nil
                                                nil ] nil.

Theorem test_sync_pop : ss_reduce test_sync_pop_state  (apply_pop_regs_one test_sync_pop_state).
  eapply (ss_sync_pop _ _); try done.
Qed.

Definition test_sync_push_state := MGood
                                     [::
                                        mk_proc_state
                                        0
                                        nil
                                        nil
                                        nil
                                        nil
                                        [:: Push (IntPtr 0 0) (size_of Int64) ]
                                        [:: LocVarBlockInt64 0 10; LocVarBlockInt64 1 11]
                                        [:: BspSync]
                                        nil
                                        nil
                                        nil ;
                                       mk_proc_state
                                         1
                                         nil
                                         nil
                                         nil
                                         nil
                                         [:: Push (IntPtr 1 0) (size_of Int64) ]
                                         [:: LocVarBlockInt64 0 11; LocVarBlockInt64 1 4; LocVarBlockInt64 2 13 ]
                                         [:: BspSync]
                                         nil
                                         nil
                                         nil ] nil.

Definition test_sync_push_state' := MGood
                                     [::
                                        mk_proc_state
                                        0
                                        nil
                                        nil
                                        nil
                                        nil
                                        nil
                                        [:: LocVarBlockInt64 0 10; LocVarBlockInt64 1 11]
                                        [:: BspSync]
                                        [:: ( IntPtr 0 0, 8 )]
                                        nil
                                        nil ;
                                       mk_proc_state
                                         1
                                         nil
                                         nil
                                         nil
                                         nil
                                         nil
                                         [:: LocVarBlockInt64 0 11; LocVarBlockInt64 1 4; LocVarBlockInt64 2 13 ]
                                         [:: BspSync]
                                         [:: ( IntPtr 1 0, 8 )]

                                         nil
                                         nil ] nil.

Theorem test_sync_push: ss_reduce test_sync_push_state test_sync_push_state'.
    by eapply (ss_sync_push _ _). Qed.

Definition test_sync_get_state := MGood
                                     [::
                                        mk_proc_state
                                        0
                                        nil
                                        [:: Get _ 1 (Goodptr Int64 0 0) (Posz 0) (Goodptr Int64 0 0) 8 ]
                                        nil
                                        nil
                                        nil
                                        [:: LocVarBlockInt64 0 10; LocVarBlockInt64 1 11]
                                        [:: BspSync]
                                        [:: ( IntPtr 0 0, 8 )]
                                        nil
                                        nil ;
                                       mk_proc_state
                                         1
                                         nil
                                         nil
                                         nil
                                         nil
                                         nil
                                         [:: LocVarBlockInt64 0 4; LocVarBlockInt64 1 5; LocVarBlockInt64 2 6 ]
                                         [:: BspSync]
                                         [:: ( IntPtr 1 0, 8 )]

                                         nil
                                         nil ] nil.
Definition test_sync_get_state':= MGood
                                     [::
                                        mk_proc_state
                                        0
                                        nil
                                        [:: Get _ 1 (Goodptr Int64 0 0) (Posz 0) (Goodptr Int64 0 0) 8 ]
                                        nil
                                        nil
                                        nil
                                        [:: LocVarBlockInt64 0 10; LocVarBlockInt64 1 11]
                                        [:: BspSync]
                                        [:: ( IntPtr 0 0, 8 )]
                                        nil
                                        nil ;
                                       mk_proc_state
                                         1
                                         nil
                                         nil
                                         nil
                                         nil
                                         nil
                                         [:: LocVarBlockInt64 0 4; LocVarBlockInt64 1 5; LocVarBlockInt64 2 6 ]
                                         [:: BspSync]
                                         [:: ( IntPtr 1 0, 8 ) ]

                                         nil
                                         nil ] nil.

Theorem test_sync_get : ss_reduce  test_sync_get_state test_sync_get_state'.
    by eapply (ss_sync_get _ _ 0).
Qed.

Definition test_sync_put_state :=  MGood
                                     [::
                                        mk_proc_state
                                        0
                                        nil
                                        nil
                                        [:: nil; [:: Put  _ (ValueI64 6) (Goodptr Int64 0 0) 0 ]]
                                        nil
                                        nil
                                        [:: LocVarBlockInt64 0 10; LocVarBlockInt64 1 11]
                                        [:: BspSync]
                                        [:: ( IntPtr 0 0, 8 )]
                                        nil
                                        nil ;
                                       mk_proc_state
                                         1
                                         nil
                                         nil
                                         nil
                                         nil
                                         nil
                                         [:: LocVarBlockInt64 0 4; LocVarBlockInt64 1 5; LocVarBlockInt64 2 6 ]
                                         [:: BspSync]
                                         [:: ( IntPtr 1 0, 8 ) ]

                                         nil
                                         nil ] nil.
Definition test_sync_put_state' :=  MGood
                                     [::
                                        mk_proc_state
                                        0
                                        nil
                                        nil
                                        [:: nil; nil]
                                        nil
                                        nil
                                        [:: LocVarBlockInt64 0 6; LocVarBlockInt64 1 11]
                                        [:: BspSync]
                                        [:: ( IntPtr 0 0, 8 )]
                                        nil
                                        nil ;
                                       mk_proc_state
                                         1
                                         nil
                                         nil
                                         nil
                                         nil
                                         nil
                                         [:: LocVarBlockInt64 0 4; LocVarBlockInt64 1 5; LocVarBlockInt64 2 6 ]
                                         [:: BspSync]
                                         [:: ( IntPtr 1 0, 8 ) ]

                                         nil
                                         nil ] nil.

Theorem test_sync_put : ss_reduce test_sync_put_state test_sync_put_state'.
by  eapply (ss_sync_put _ _ 0 1).
Qed.

Definition test_hpput_state :=  MGood [::
                                        mk_proc_state
                                        0
                                        nil
                                        nil
                                        [:: nil ; nil ]
                                        nil
                                        nil
                                        [:: LocVarBlockInt64 0 10; LocVarBlockInt64 1 11]
                                        nil
                                        [:: ( IntPtr 0 0, 8 )]
                                        nil
                                        nil ;
                                       mk_proc_state
                                         1
                                         nil
                                         nil
                                         [:: nil; nil]
                                         nil
                                         nil
                                         [:: LocVarBlockInt64 0 4; LocVarBlockInt64 1 5; LocVarBlockInt64 2 6 ]
                                         [:: BspHpPut (Lit $ ValueI64 0)
                                            (Lit $ VIntPtr 2 0)
                                            (Lit $ ValueI64 0)
                                            (Lit $ VIntPtr 1 0)
                                            (Lit $ ValueI64 8) ]

                                         [:: ( IntPtr 2 0, 8 )]

                                         nil
                                         nil ] nil.

Theorem test_hpput: reduce_interp test_hpput_state.
    by  eapply (ss_bsp_hpput _ _ 1).
Qed.

Definition test_hpget_state :=  MGood [::
                                        mk_proc_state
                                        0
                                        nil
                                        nil
                                        [:: nil ; nil ]
                                        nil
                                        nil
                                        [:: LocVarBlockInt64 0 10; LocVarBlockInt64 1 11]
                                        nil
                                        [:: ( IntPtr 0 0, 8 )]
                                        nil
                                        nil ;
                                       mk_proc_state
                                         1
                                         nil
                                         nil
                                         [:: nil; nil]
                                         nil
                                         nil
                                         [:: LocVarBlockInt64 0 4; LocVarBlockInt64 1 5; LocVarBlockInt64 2 6 ]
                                         [:: BspHpGet (Lit $ ValueI64 0)
                                            (Lit $ VIntPtr 2 0)
                                            (Lit $ ValueI64 0)
                                            (Lit $ VIntPtr 1 0)
                                            (Lit $ ValueI64 8) ]

                                         [:: ( IntPtr 2 0, 8 )]

                                         nil
                                         nil ] nil.

Compute interpret_ss test_hpget_state 1.

Theorem test_hpget: reduce_interp test_hpget_state.
  by  eapply (ss_bsp_hpget _ _ 1); try done.
Qed.

Definition test_hpput_sync: ss_reduce ( MGood [::
                                                 mk_proc_state 0 nil nil nil nil nil
                                                 [:: LocVarBlockInt64 0 10; LocVarBlockInt64 1 11;
                                                  LocVarBlockInt64 2 12; LocVarBlockInt64 3 13 ]
                                                 [:: BspSync]
                                                 [:: (iptr 0 0, 8 ) ]
                                                 [:: nil; [::
                                                             HpPutQuery
                                                             (iptr 1 0)
                                                             (iptr 0 0)
                                                             0] ]
                                                 nil ;

                                                 mk_proc_state 1 nil nil nil nil nil
                                                 [:: LocVarBlockInt64 0 20; LocVarBlockInt64 1 21;
                                                  LocVarBlockInt64 2 22; LocVarBlockInt64 3 23 ]
                                                 [:: BspSync]
                                                 [:: ( iptr 1 0 , 8 ) ]
                                                 [:: nil; nil]
                                                 nil
                                              ] [::] )
                                      (
                                        MGood [::
                                                 mk_proc_state 0 nil nil nil nil nil
                                                 [:: LocVarBlockInt64 0 21; LocVarBlockInt64 1 11;
                                                  LocVarBlockInt64 2 12; LocVarBlockInt64 3 13 ]
                                                 [:: BspSync]
                                                 [:: ( iptr 0 0, 8 ) ]
                                                 [:: nil; [::] ]
                                                 nil ;

                                                 mk_proc_state 1 nil nil nil nil nil
                                                 [:: LocVarBlockInt64 0 20; LocVarBlockInt64 1 21;
                                                  LocVarBlockInt64 2 22; LocVarBlockInt64 3 23 ]
                                                 [:: BspSync]
                                                 [:: ( iptr 1 0 , 8 ) ]
                                                 [:: nil; nil]
                                                 nil
      ] [::] ).
 by eapply (ss_sync_hpput _ _ 0 1).
Qed.

Definition test_hpget_sync: ss_reduce ( MGood [::
                                                 mk_proc_state 0 nil nil nil nil nil
                                                 [:: LocVarBlockInt64 0 10; LocVarBlockInt64 1 11;
                                                  LocVarBlockInt64 2 12; LocVarBlockInt64 3 13 ]
                                                 [:: BspSync]
                                                 [:: (iptr 0 0, 8 ) ]
                                                 nil
                                                 [:: nil; [::
                                                             HpGetQuery
                                                             (iptr 1 0)
                                                             (iptr 0 0)
                                                             0] ]
                                                 ;

                                                 mk_proc_state 1 nil nil nil nil nil
                                                 [:: LocVarBlockInt64 0 20; LocVarBlockInt64 1 21;
                                                  LocVarBlockInt64 2 22; LocVarBlockInt64 3 23 ]
                                                 [:: BspSync]
                                                 [:: ( iptr 1 0 , 8 ) ]
                                                 nil
                                                 nil
                                              ] [::] )
                                      (
                                        MGood [::
                                                 mk_proc_state 0 nil nil nil nil nil
                                                 [:: LocVarBlockInt64 0 21; LocVarBlockInt64 1 11;
                                                  LocVarBlockInt64 2 12; LocVarBlockInt64 3 13 ]
                                                 [:: BspSync]
                                                 [:: ( iptr 0 0, 8 ) ]
                                                 nil
                                                 [:: nil; nil]  ;

                                                 mk_proc_state 1 nil nil nil nil nil
                                                 [:: LocVarBlockInt64 0 20; LocVarBlockInt64 1 21;
                                                  LocVarBlockInt64 2 22; LocVarBlockInt64 3 23 ]
                                                 [:: BspSync]
                                                 [:: ( iptr 1 0 , 8 ) ]
                                                 nil
                                                 nil
      ] [::] ).
  by eapply (ss_sync_hpget _ _ 0 1).
Qed.