(** Cut Elimination for Focused Linear Logic

This file proves cut-elimination for the triadic system of linear
logic. The proof uses 5 cut-rules dealing with the negative and
positive phase of proofs (see [CutElimBase]).

It is assumed that the theory only produces well formed LL formulas
(see [TheoryIsFormula]).
 *)

Require Export MMLL.Misc.Hybrid.
Require Export MMLL.SL.FLLTactics.
Require Import Lia.
Require Import MMLL.Misc.Permutations.
Require Import FunInd.
Require Import Coq.Program.Equality.
Require Export MMLL.SL.InvPositivePhase.

Export ListNotations.
Export LLNotations.
Set Implicit Arguments.

Section CutElimination.
Context `{OLS: OLSig}.
Context `{SI : Signature}.
Context {USI : UnbSignature}.

Local Hint Resolve allU :core.

  Variable theory : oo -> Prop .
  Notation " n '|---' B ';' L ';' X " := (seqN theory n B L X) (at level 80).
  Notation " '|--' B ';' L ';' X " := (seq theory B L X) (at level 80).

 Lemma simplUnb B D:
  Permutation (getU B) (getU D) ->
  Permutation B D.
  Proof.
  intros.
  rewrite (cxtDestruct B).
  rewrite (cxtDestruct D).
  rewrite H.
  rewrite allSeTLEmpty;auto.
  rewrite allSeTLEmpty;auto.
  Qed.

 Lemma InvBangTN i j B P : mt i = true ->
           j |--- B; []; (DW (Bang i  P)) -> (j-1) |--- B; []; (UP [P]).
  Proof with sauto.
  intros Hm Hj.
  inversion Hj...
  inversion H0.
  eapply InvSubExpPhaseUT in H4;auto.
  destruct H4 as [C4 H4].
  destruct H4 as [CK H4].
  destruct H4 as [CN H4]...
  rewrite H.
  rewrite app_assoc.
  apply weakeningGenN_rev;auto.
  rewrite Permutation_app_comm.
  apply ContractionL...
  LLPerm ((C4 ++ Loc CK) ++ CK).
  apply weakeningGenN_rev;auto.
  eapply @HeightGeq with (n:=n - length (C4 ++ CK) - 1)...
 Qed.

 Lemma InvBangTNLoc i j A B P : mt i = true -> m4 i = true ->
       j |--- (loc,A)::B; []; (DW (Bang i P)) ->
       (exists C4 CN, Permutation B (C4++CN) /\ (j - length C4 - 2) |--- C4; []; (UP [P]) /\ SetK4 C4 /\ SetT C4 /\ LtX i C4 ).
  Proof with sauto.
  intros HmT Hm4 Hj.
  assert(i <> loc).
  solveSignature1.
  inversion Hj;subst;auto.
  inversion H1.
  assert(False).
  apply H... sauto.
  eapply InvSubExpPhaseUTK4 in H5;auto.
  destruct H5 as [C4 H5].
  destruct H5 as [CN H5]...
  checkPermutationCases H0.
  rewrite H0 in H2.
  inversion H2... solveSignature1.
  exists C4.
  exists x.
  split;sauto.
  eapply @HeightGeq with (n:=n - length C4 - 1)...
  rewrite NatComp...
 Qed.

  Lemma InvBangT i j B P : mt i = true ->
           j |--- B; []; (DW (Bang i P)) -> |-- B; []; (UP [P]).
  Proof with sauto.
  intros Hm Hj.
  apply InvBangTN in Hj...
  apply seqNtoSeq in Hj...
 Qed.

     Lemma LtXPlusT  a K : LtX a K -> LtX (plust a) (PlusT K).
  Proof with sauto.
  induction K;simpl;intros...
  destruct a0 as [b F].
  inversion H...
  apply IHK in H3...
  apply Forall_cons...
   apply plust_mono ...
  Qed.
Lemma BangPlusT n C P a : a <> loc -> SetK4 C -> LtX a C -> n >= length C + 1 ->
        n - length C - 1 |--- PlusT C; []; (UP [P]) ->
        S n |--- PlusT C; []; (DW (Bang (plust a) P)).
Proof with sauto.
 intros.
  createWorld.
  apply plust_loc_diff...
  eapply @GenK4Rel with (C4:=PlusT C) (CK:=[]) (CN:=[])...
  apply plust_loc_diff...
  apply SetK4PlusT...
  apply LtXPlusT...
  autounfold.
  rewrite map_length...
  simpl...
  simplFix...
  autounfold.
  rewrite map_length...
Qed.

  Theorem CutElimBase a C dualC A dualA B L M N P:
    dualC = dual C ->
      (0 |--- B; M ++ [C]; (UP L) -> 0 |--- B; N; (UP [dualC]) -> |-- B; M ++ N; (UP L)) /\
      (0 |--- B; M; (UP (C :: L)) -> 0 |--- B; N; (DW dualC) -> |-- B; M ++ N; (UP L)) /\
      (dualA = A ^ ->
       dualC = Bang a dualA ->
       0 |--- B ++ [(a,A)] ; M; (DW P) -> 0 |--- B; []; (DW (Bang a dualA)) -> |-- B; M; (UP [P]))  /\
     (dualA = A ^ ->
       dualC = Bang a dualA ->
       0 |--- B ++ [(a,A)] ; M; (UP L) -> 0 |--- B; []; (DW (Bang a dualA)) -> |-- B; M; (UP L)).

  Proof with sauto;try solveLL.
    intros CDual.
    split;[intros
          |split;[intros
          |split;intros]].
    * inversion H...
    * inversion H...
      inversion H0.
    * inversion H2...
    * inversion H2...
  Qed.

   Definition CutW (w: nat) :=
    forall a m i j C dualC A dualA P M N L B,
    m <= w ->
    dualC = C ^ ->
    complexity C = m ->
      (i |--- B; M ++ [C]; (UP L) -> j |--- B; N; (UP [dualC]) -> |-- B; M ++ N; (UP L)) /\
      (i |--- B; M; (UP (C :: L)) -> j |--- B; N; (DW dualC) -> |-- B; M ++ N; (UP L)) /\
       (dualA = A ^ ->
       dualC = Bang a dualA ->
       i |--- B ++ [(a,A)] ; M; (DW P) -> j |--- B; []; (DW (Bang a dualA)) -> |-- B; M; (UP [P]))  /\
      (dualA = A ^ ->
       dualC = Bang a dualA ->
       i |--- B ++ [(a,A)] ; M; (UP L) -> j |--- B; []; (DW (Bang a dualA)) -> |-- B; M; (UP L)).

  Definition CutH (w h: nat) :=
    forall a m i j C dualC A dualA P M N L B,
    m <= h ->
    m = i + j ->
    dualC = C ^ ->
    complexity C = S w ->
      (i |--- B; M ++ [C]; (UP L) -> j |--- B; N; (UP [dualC]) -> |-- B; M ++ N; (UP L)) /\
      (i |--- B; M; (UP (C :: L)) -> j |--- B; N; (DW dualC) -> |-- B; M ++ N; (UP L)) /\
      (dualA = A ^ ->
       dualC = Bang a dualA ->
       i |--- B ++ [(a,A)] ; M; (DW P) -> j |--- B; []; (DW (Bang a dualA)) -> |-- B; M; (UP [P]))   /\
      (dualA = A ^ ->
       dualC = Bang a dualA ->
       i |--- B ++ [(a,A)] ; M; (UP L) -> j |--- B; []; (DW (Bang a dualA)) -> |-- B; M; (UP L)).

Theorem CutUPLStar  i j w h C L M N B : CutH w h -> complexity C = S w -> S h = i + j ->
  i |--- B; M ++ [C]; (UP L) ->
  j |--- B; N; (UP [C ^]) ->
  |-- B; M ++ N; (UP L ).
Proof with sauto;try solveLL.
 intros CH compC hH Hi Hj.
 inversion Hi...
 * assert(n |--- B; M ++ [C]; (UP M0) ->
          j |--- B; N; (UP [dual C]) ->
            |-- B; M ++ N; (UP M0)) as Cut.
           eapply CH...

           apply Cut...
 * assert(n |--- B; M ++ [C]; (UP (F :: G :: M0)) ->
          j |--- B; N; (UP [dual C]) ->
            |-- B; M ++ N; (UP (F :: G :: M0))) as Cut.
           eapply CH...

           apply Cut...
 * assert(n |--- B; M ++ [C]; (UP (F  :: M0)) ->
          j |--- B; N; (UP [dual C]) ->
            |-- B; M ++ N; (UP (F :: M0))) as CutF.
           eapply CH...

           apply CutF...

 * assert(n |--- B; M ++ [C]; (UP (G  :: M0)) ->
          j |--- B; N; (UP [dual C]) ->
            |-- B; M ++ N; (UP (G :: M0))) as CutG.
           eapply CH...

           apply CutG...

 * assert(n |--- B ++ [(i0, F)]; M ++ [C]; (UP M0) ->
            j |--- B ++ [(i0, F)]; N; (UP [dual C]) ->
              |-- B ++ [(i0, F)]; M ++ N; (UP M0)) as Cut.
           eapply CH...
           rewrite Permutation_cons_append.
           apply Cut...
           LLExact H3.
           apply weakeningGenN_rev...
 * assert(n |--- B; (M ++ [F]) ++ [C]; (UP M0) ->
          j |--- B; N; (UP [dual C]) ->
            |-- B; (M ++ [F]) ++ N; (UP M0)) as Cut.
           eapply CH...

           LLPerm((M ++ [F]) ++ N).
           apply Cut...
           LLExact H4.
 *checkPermutationCases H1.
   2:{ inversion H1...
       rewrite H2.
       assert(j |--- B; N; (UP [dual C]) ->
              n |--- B; L'; (DW C) ->
                |-- B; N++L'; (UP [])) as Cut.
       eapply CH with (m:=n + j)...

       lia.
       rewrite <- ng_involutive...
       rewrite DualComplexity in compC...
       LLPerm(N ++ L')... }

   destruct(PositiveOrNegative F).
   2:{ inversion H5;CleanContext...
       rewrite H1.
       rewrite <- app_comm_cons.
        LFocus. LLRelease.
        assert(S n0 |--- B; x++ [C]; (UP [F]) ->
               j |--- B; N; (UP [dual C]) ->
                 |-- B; x ++ N; (UP [F])) as Cut.
                eapply CH with (m:=S n0 + j)...
                apply Cut...
                rewrite <- H2 in H9.
                LLExact H9. }
       inversion H5...
            {
              inversion Hj...
              apply seqNtoSeq in H7... }
            {  apply simplUnb in H7.
               apply simplUnb in H6.
               clear H8.
              rewrite H4 in H2.
              checkPermutationCases H2.
              -
              destruct(PositiveOrNegative F0).
              { (* first *)
              assert(S n0 |--- B; (F0::x0)++[C]; (UP [])).
              LFocus F0 (x0++[C])...
              rewrite <- H2... LLExact H9.
              rewrite H1.
              rewrite <- app_comm_cons.
              apply TensorComm'.
              rewrite <- H3.
              LLPerm(MAnd G F0::N0++(x0++N)).
              rewrite <- (app_nil_l [ ]).
              eapply @InvTensor with (B:=B) (D:=B)...

              apply Derivation1.
              apply seqNtoSeq in H13...
              LLExact H13.
              assert(S n0 |--- B; (F0::x0) ++ [C]; (UP [ ]) ->
                       j |--- B; N; (UP [dual C]) ->
                         |-- B; (F0::x0) ++ N; (UP [ ])) as Cut.
                eapply CH...
                rewrite <- (app_nil_l [F0]).
               apply UpExtension'.
               inversion H2...

               LLPerm((F0 :: x0) ++ N)...
               }
             { (* second *)
              inversion H9;CleanContext...
              rewrite H1.
              rewrite <- app_comm_cons.
              apply TensorComm'.
              rewrite <- H3.
              LLPerm(MAnd G F0::N0++(x0++N)).
                rewrite <- (app_nil_l [ ]).
              eapply @InvTensor with (B:=B) (D:=B)...
                apply Derivation1.
                apply seqNtoSeq in H13... LLExact H13.
                 assert(n |--- B; x0 ++ [C]; (UP [F0]) ->
                       j |--- B; N; (UP [dual C]) ->
                         |-- B; x0 ++ N; (UP [F0])) as Cut.
                eapply CH with (m:=n + j)...
                apply Cut...
                inversion H9;solveF...
                LLExact H14. }
             -
              destruct(PositiveOrNegative G).
              { (* first *)
              assert(S n0 |--- B; (G::x0)++[C]; (UP [])).
              LFocus G (x0++[C])...
              rewrite <- H2... LLExact H13.
              rewrite H1.
              rewrite <- H3.
              LLPerm(MAnd F0 G::M0++(x0++N)).
              rewrite <- (app_nil_l [ ]).
              eapply @InvTensor with (B:=B) (D:=B)...
              apply Derivation1.
              apply seqNtoSeq in H9...    LLExact H9.

              assert(S n0 |--- B; (G::x0) ++ [C]; (UP [ ]) ->
                       j |--- B; N; (UP [dual C]) ->
                         |-- B; (G::x0) ++ N; (UP [ ])) as Cut.
                eapply CH...
                  rewrite <- (app_nil_l [G]).

               apply UpExtension'.
               inversion H2...

               LLPerm((G :: x0) ++ N)... }
             { (* second *)
              inversion H13;CleanContext...
              rewrite H1.
              rewrite <- H3.
              LLPerm(MAnd F0 G::M0++(x0++N)).
              rewrite <- (app_nil_l [ ]).
              eapply @InvTensor with (B:=B) (D:=B)...
                apply Derivation1.
                apply seqNtoSeq in H9... LLExact H9.
              assert(n |--- B; x0++ [C]; (UP [G ]) ->
                          j |--- B; N; (UP [dual C]) ->
                         |-- B; x0 ++ N; (UP [G])) as Cut.
                 eapply CH with (m:=n + j)...

                inversion H13;solveF...
                apply Cut... LLExact H14. }
                }
    -   destruct(PositiveOrNegative F0).
       { rewrite H1.
                 rewrite <- app_comm_cons.
                 apply InvPlus...
                 LLStore.
                assert((S n0) |--- B; (F0::x) ++ [C]; (UP [ ]) ->
                       j |--- B; N; (UP [dual C]) ->
                         |-- B; (F0::x) ++ N; (UP [ ])) as Cut.
                eapply CH with (m:=(S n0) + j)...
                rewrite app_comm_cons...
                apply Cut...
                 rewrite <- app_comm_cons...
                 LFocus F0.
               LLExact H8. }
             {   inversion H8;CleanContext...
                 rewrite H1.
                 rewrite <- app_comm_cons.
                 apply InvPlus...
                assert(n |--- B; x ++ [C]; (UP [F0]) ->
                       j |--- B; N; (UP [dual C]) ->
                         |-- B; x ++ N; (UP [F0])) as Cut.
                eapply CH with (m:= n + j)...
               apply Cut... LLExact H10.
               }
  -    destruct(PositiveOrNegative G).
       {         rewrite H1.
                 rewrite <- app_comm_cons.
                 apply InvPlusComm...
                 LLStore.

                assert((S n0) |--- B; (G::x) ++ [C]; (UP [ ]) ->
                       j |--- B; N; (UP [dual C]) ->
                         |-- B; (G::x ) ++ N; (UP [ ])) as Cut.
                eapply CH with (m:=(S n0) + j)...
                rewrite app_comm_cons...
                apply Cut...
                 rewrite <- app_comm_cons...
                 LFocus G.
               LLExact H8. }
             {   inversion H8;CleanContext...
                 rewrite H1.
                 rewrite <- app_comm_cons.
                 apply InvPlusComm...
                assert(n |--- B; x ++ [C]; (UP [G]) ->
                       j |--- B; N; (UP [dual C]) ->
                         |-- B; x ++ N; (UP [G])) as Cut.
                eapply CH with (m:= n + j)...
               apply Cut... LLExact H10.
               }
   -  apply PositiveNotNegative in H. contradiction.
   -   destruct(PositiveOrNegative (FX t)).
       { rewrite H1.
                 rewrite <- app_comm_cons.
                 apply @InvEx with (t:=t)...
                 LLStore.
                assert((S n0) |--- B; (FX t::x) ++ [C]; (UP [ ]) ->
                       j |--- B; N; (UP [dual C]) ->
                         |-- B; (FX t::x) ++ N; (UP [ ])) as Cut.
                eapply CH with (m:=(S n0) + j)...
                rewrite app_comm_cons...
                apply Cut...
                 rewrite <- app_comm_cons...
                 LFocus (FX t).
               LLExact H10. }
             {   inversion H10;subst;auto;
               try match goal with
               [ H1: _ = FX t, H2: negativeFormula (FX t) |- _] => rewrite <- H1 in H2;inversion H2
                end.
                 rewrite H1.
                 rewrite <- app_comm_cons.
                 apply @InvEx with (t:=t)...
                assert(n |--- B; x ++ [C]; (UP [FX t]) ->
                       j |--- B; N; (UP [dual C]) ->
                         |-- B; x ++ N; (UP [FX t])) as Cut.
                eapply CH with (m:= n + j)...
               apply Cut... LLExact H12. }
*  destruct(PositiveOrNegative F).
   2:{ inversion H7;CleanContext...
       apply @AbsorptionClassic' with (i:=i0) (F:=F)...
        assert(n0 |--- B; M ++ [C]; (UP [F]) ->
                j |--- B; N; (UP [dual C]) ->
                  |-- B; M ++ N; (UP [F])) as Cut.
       eapply CH with (m:=n0 + j)...
       apply Cut... }
       inversion H7...
       -  apply @AbsorptionClassic' with (i:=i0) (F:=perp A)...
          inversion Hj...
          apply seqNtoSeq in H12...
       - apply simplUnb in H6.
         apply simplUnb in H8. clear H9.
         checkPermutationCases H5.
          {  destruct(PositiveOrNegative F0).
             { (* first *)
               rewrite <- H9.
               LLPerm((x ++ N) ++ N0).
               rewrite <- (app_nil_r []).
               eapply @InvTensorC with (F:=F0) (G:=G) (i:=i0) (B:=B) (D:=B)...
               rewrite <- (app_nil_l [F0]).
               apply UpExtension'.
                inversion H4...

                 assert(S n0 |--- B; (F0::x) ++ [C]; (UP [ ]) ->
                       j |--- B; N; (UP [dual C]) ->
                         |-- B; (F0::x) ++ N; (UP [ ])) as Cut.
                eapply CH...
               LLPerm((F0 :: x) ++ N)... apply Cut...
               rewrite <- app_comm_cons.
               LFocus F0.
               LLExact H10.
               apply Derivation1.
               apply seqNtoSeq in H14... LLExact H14. }
            { (* first *)
               rewrite <- H9.
               inversion H10;CleanContext...
               LLPerm((x++N)++N0).
               rewrite <- (app_nil_r []).

               eapply @InvTensorC with (F:=F0) (G:=G) (i:=i0) (B:=B) (D:=B)...
                 assert(n |--- B; x ++ [C]; (UP [F0]) ->
                       j |--- B; N; (UP [dual C]) ->
                         |-- B; x ++ N; (UP [F0])) as Cut.
                eapply CH with (m:=n+j)...
                apply Cut...
                LLExact H17.
               apply Derivation1.
               apply seqNtoSeq in H14... LLExact H14. } }
          {  destruct(PositiveOrNegative G).
             { (* first *)
               rewrite <- H9.
               LLPerm(M0++(x ++ N)).
               rewrite <- (app_nil_r []).
               eapply @InvTensorC with (F:=F0) (G:=G) (i:=i0) (B:=B) (D:=B)...
               apply Derivation1.
               apply seqNtoSeq in H10... LLExact H10.

               rewrite <- (app_nil_l [G]).
               apply UpExtension'.
                inversion H4...

                 assert(S n0 |--- B; (G::x) ++ [C]; (UP [ ]) ->
                       j |--- B; N; (UP [dual C]) ->
                         |-- B; (G::x) ++ N; (UP [ ])) as Cut.
                eapply CH...
               LLPerm((G :: x) ++ N)... apply Cut...
               rewrite <- app_comm_cons.
               LFocus G.
               LLExact H14.  }
            { (* first *)
               rewrite <- H9.
               inversion H14;CleanContext...
               LLPerm(M0++(x ++ N)).
               rewrite <- (app_nil_r []).

               eapply @InvTensorC with (F:=F0) (G:=G) (i:=i0) (B:=B) (D:=B)...
               apply Derivation1.
               apply seqNtoSeq in H10... LLExact H10.

                 assert(n |--- B; x ++ [C]; (UP [G]) ->
                       j |--- B; N; (UP [dual C]) ->
                         |-- B; x ++ N; (UP [G])) as Cut.
                eapply CH with (m:=n+j)...
                apply Cut...
                LLExact H17. } }
  -  destruct(PositiveOrNegative F0).
     {  eapply @InvPlusC with (F:=F0) (G:=G) (i:=i0)...
        rewrite <- (app_nil_l [F0]).
        apply UpExtension'.
        inversion H4...
        assert(S n0 |--- B; (F0::M) ++ [C]; (UP [ ]) ->
                  j |--- B; N; (UP [dual C]) ->
                    |-- B; (F0::M) ++ N; (UP [ ])) as Cut.
                eapply CH with (m:=S n0 + j)...
               LLPerm( (F0::M) ++ N)...
               apply Cut...
               rewrite <- app_comm_cons.
               LFocus F0.  }

     {  inversion H9;CleanContext...
        eapply @InvPlusC with (F:=F0) (G:=G) (i:=i0)...
        assert( n |--- B; M ++ [C]; (UP [F0]) ->
                j |--- B; N; (UP [dual C]) ->
                 |-- B; M ++ N; (UP [F0])) as Cut.
                eapply CH with (m:=n + j)...
                apply Cut... }
  -  destruct(PositiveOrNegative G).
     {  eapply @InvPlusCComm with (F:=F0) (G:=G) (i:=i0)...
        rewrite <- (app_nil_l [G]).
        apply UpExtension'.
        inversion H4...
        assert(S n0 |--- B; (G::M) ++ [C]; (UP [ ]) ->
                  j |--- B; N; (UP [dual C]) ->
                    |-- B; (G::M) ++ N; (UP [ ])) as Cut.
                eapply CH with (m:=S n0 + j)...
               LLPerm( (G::M) ++ N)...
               apply Cut...
               rewrite <- app_comm_cons.
               LFocus G. }

     {  inversion H9;CleanContext...
        eapply @InvPlusCComm with (F:=F0) (G:=G) (i:=i0)...
        assert( n |--- B; M ++ [C]; (UP [G]) ->
                j |--- B; N; (UP [dual C]) ->
                 |-- B; M ++ N; (UP [G])) as Cut.
                eapply CH with (m:=n + j)...
                apply Cut... }

  -  apply PositiveNotNegative in H. contradiction.
  -  destruct(PositiveOrNegative (FX t)).
     {  eapply @InvExC with  (i:=i0) (t:=t) (FX:=FX)...
        rewrite <- (app_nil_l [FX t]).
        apply UpExtension'.
        inversion H4...
        assert(S n0 |--- B; (FX t::M) ++ [C]; (UP [ ]) ->
                  j |--- B; N; (UP [dual C]) ->
                    |-- B; (FX t::M) ++ N; (UP [ ])) as Cut.
                eapply CH with (m:=S n0 + j)...
        LLPerm((FX t :: M) ++ N)...
        apply Cut...
        rewrite <- app_comm_cons.
        LFocus (FX t).      }
     {  inversion H11;subst;auto;
               try match goal with
               [ H1: _ = FX t, H2: negativeFormula (FX t) |- _] => rewrite <- H1 in H2;inversion H2
                end.
        eapply @InvExC with  (i:=i0) (t:=t) (FX:=FX)...
        assert( n |--- B; M ++ [C]; (UP [FX t]) ->
                j |--- B; N; (UP [dual C]) ->
                 |-- B; M ++ N; (UP [FX t])) as Cut.
                eapply CH with (m:=n + j)...
                apply Cut... }
 * rewrite allU in H0...
 *  destruct(PositiveOrNegative F).
    2:{ inversion H5;CleanContext...
        destruct (NegativeAtomDec F).
        assert(False).
        inversion H;subst... inversion H3.
        contradiction.
        apply @AbsorptionTheory with (F:=F)...
        assert(n0 |--- B; M ++ [C]; (UP [F]) ->
                  j |--- B; N; (UP [dual C]) ->
                    |-- B; M ++ N; (UP [F])) as Cut.

                eapply CH with (m:=n0 + j)...

                apply Cut... }
    inversion H5...
    -   eapply @AbsorptionPerp' with (A:=A)...
        inversion Hj...
        apply seqNtoSeq in H10...
    -  apply simplUnb in H6.
       apply simplUnb in H4. clear H7.
       checkPermutationCases H3.
          {  destruct(PositiveOrNegative F0).
             { (* first *)
               rewrite <- H7.
               LLPerm((x ++ N) ++ N0).
               rewrite <- (app_nil_r []).
               eapply @InvTensorT with (F:=F0) (G:=G) (B:=B) (D:=B)...
               rewrite <- (app_nil_l [F0]).
               apply UpExtension'.
                inversion H2...

                 assert(S n0 |--- B; (F0::x) ++ [C]; (UP [ ]) ->
                       j |--- B; N; (UP [dual C]) ->
                         |-- B; (F0::x) ++ N; (UP [ ])) as Cut.
                eapply CH...
               LLPerm((F0 :: x) ++ N)... apply Cut...
               rewrite <- app_comm_cons.
               LFocus F0.
               LLExact H8.
               apply Derivation1.
               apply seqNtoSeq in H12... LLExact H12. }
            { (* first *)
               rewrite <- H7.
               inversion H8;CleanContext...
               LLPerm((x++N)++N0).
               rewrite <- (app_nil_r []).

               eapply @InvTensorT with (F:=F0) (G:=G) (B:=B) (D:=B)...
                 assert(n |--- B; x ++ [C]; (UP [F0]) ->
                       j |--- B; N; (UP [dual C]) ->
                         |-- B; x ++ N; (UP [F0])) as Cut.
                eapply CH with (m:=n+j)...
                apply Cut...
                LLExact H15.
               apply Derivation1.
               apply seqNtoSeq in H12... LLExact H12. } }
          {  destruct(PositiveOrNegative G).
             { (* first *)
               rewrite <- H7.
               LLPerm(M0++(x ++ N)).
               rewrite <- (app_nil_r []).
               eapply @InvTensorT with (F:=F0) (G:=G) (B:=B) (D:=B)...
               apply Derivation1.
               apply seqNtoSeq in H8... LLExact H8.

               rewrite <- (app_nil_l [G]).
               apply UpExtension'.
                inversion H2...

                 assert(S n0 |--- B; (G::x) ++ [C]; (UP [ ]) ->
                       j |--- B; N; (UP [dual C]) ->
                         |-- B; (G::x) ++ N; (UP [ ])) as Cut.
                eapply CH...
               LLPerm((G :: x) ++ N)... apply Cut...
               rewrite <- app_comm_cons.
               LFocus G.
               LLExact H12.  }
            { (* first *)
               rewrite <- H7.
               inversion H12;CleanContext...
               LLPerm(M0++(x ++ N)).
               rewrite <- (app_nil_r []).

               eapply @InvTensorT with (F:=F0) (G:=G) (B:=B) (D:=B)...
               apply Derivation1.
               apply seqNtoSeq in H8... LLExact H8.

                 assert(n |--- B; x ++ [C]; (UP [G]) ->
                       j |--- B; N; (UP [dual C]) ->
                         |-- B; x ++ N; (UP [G])) as Cut.
                eapply CH with (m:=n+j)...
                apply Cut...
                LLExact H15. } }
  -  destruct(PositiveOrNegative F0).
     {  eapply @InvPlusT with (F:=F0) (G:=G)...
        rewrite <- (app_nil_l [F0]).
        apply UpExtension'.
        inversion H2...
        assert(S n0 |--- B; (F0::M) ++ [C]; (UP [ ]) ->
                  j |--- B; N; (UP [dual C]) ->
                    |-- B; (F0::M) ++ N; (UP [ ])) as Cut.
                eapply CH with (m:=S n0 + j)...
               LLPerm( (F0::M) ++ N)...
               apply Cut...
               rewrite <- app_comm_cons.
               LFocus F0.  }

     {  inversion H7;CleanContext...
        eapply @InvPlusT with (F:=F0) (G:=G)...
        assert( n |--- B; M ++ [C]; (UP [F0]) ->
                j |--- B; N; (UP [dual C]) ->
                 |-- B; M ++ N; (UP [F0])) as Cut.
                eapply CH with (m:=n + j)...
                apply Cut... }
  -  destruct(PositiveOrNegative G).
     {  eapply @InvPlusTComm with (F:=F0) (G:=G)...
        rewrite <- (app_nil_l [G]).
        apply UpExtension'.
        inversion H2...
        assert(S n0 |--- B; (G::M) ++ [C]; (UP [ ]) ->
                  j |--- B; N; (UP [dual C]) ->
                    |-- B; (G::M) ++ N; (UP [ ])) as Cut.
                eapply CH with (m:=S n0 + j)...
               LLPerm( (G::M) ++ N)...
               apply Cut...
               rewrite <- app_comm_cons.
               LFocus G. }

     {  inversion H7;CleanContext...
        eapply @InvPlusTComm with (F:=F0) (G:=G)...
        assert( n |--- B; M ++ [C]; (UP [G]) ->
                j |--- B; N; (UP [dual C]) ->
                 |-- B; M ++ N; (UP [G])) as Cut.
                eapply CH with (m:=n + j)...
                apply Cut... }

  -  apply PositiveNotNegative in H. contradiction.
  -  destruct(PositiveOrNegative (FX t)).
     {  eapply @InvExT with (t:=t) (FX:=FX)...
        rewrite <- (app_nil_l [FX t]).
        apply UpExtension'.
        inversion H2...
        assert(S n0 |--- B; (FX t::M) ++ [C]; (UP [ ]) ->
                  j |--- B; N; (UP [dual C]) ->
                    |-- B; (FX t::M) ++ N; (UP [ ])) as Cut.
                eapply CH with (m:=S n0 + j)...
        LLPerm((FX t :: M) ++ N)...
        apply Cut...
        rewrite <- app_comm_cons.
        LFocus (FX t).      }
     {  inversion H9;subst;auto;
               try match goal with
               [ H1: _ = FX t, H2: negativeFormula (FX t) |- _] => rewrite <- H1 in H2;inversion H2
                end.
        eapply @InvExT with (t:=t) (FX:=FX)...
        assert( n |--- B; M ++ [C]; (UP [FX t]) ->
                j |--- B; N; (UP [dual C]) ->
                 |-- B; M ++ N; (UP [FX t])) as Cut.
                eapply CH with (m:=n + j)...
                apply Cut... }
  *  assert(n |--- B; M ++ [C]; (UP (FX x :: M0)) ->
           j |--- B; N; (UP [dual C]) ->
             |-- B; M ++ N; (UP (FX x :: M0))) as Cut.
           eapply CH...

           apply H4 in properX...
  Qed.

Theorem CutUP  i j w h C L M N B : CutH w h -> CutW w -> complexity C = S w -> S h = i + j ->
  i |--- B; M; (UP (C::L)) ->
  j |--- B; N; (DW (dual C)) ->
  |-- B; M ++ N; (UP L).
Proof with sauto;try solveLL.
 intros CH CW compC hH Hi Hj.
 inversion Hi;subst.
 * inversion Hj...
   CleanContext.
 * inversion Hj; CleanContext...
   apply seqNtoSeq  in H3;auto.
 * inversion Hj; CleanContext...
   apply simplUnb in H2.
   apply simplUnb in H4.
   clear H5.
   rewrite <- H2 in H9.
   rewrite <- H4 in H10.

   rewrite H1.
   assert( n |--- B; M; (UP (F :: G :: L)) ->
          n0 |--- B; M0; (DW (dual F)) ->
             |-- B; M ++ M0 ; (UP (G :: L))) as HcutF.
    eapply CW with (m:=complexity F)...
    inversion compC...
    apply HcutF in H9;auto.
    apply seqtoSeqN in H9.
    destruct H9.

    assert( x |--- B; M ++ M0; (UP (G :: L)) ->
           n0 |--- B; N0; (DW (dual G )) ->
              |-- B; (M ++ M0) ++ N0; UP L) as HcutG.
      eapply CW with (m:=complexity G)...

      inversion compC...
      LLPerm((M ++ M0) ++ N0)...
 * inversion Hj; CleanContext...
   assert( n |--- B; M; (UP (F :: L)) ->
          n0 |--- B; N; (DW (dual F )) ->
             |-- B; M ++ N; (UP L)) as HcutF.
    eapply CW with (m:=complexity F)...

    inversion compC...
    apply  HcutF ...
  assert( n |--- B; M; (UP (G :: L)) ->
          n0 |--- B; N; (DW (dual G )) ->
             |-- B; M ++ N; (UP L)) as HcutG.
    eapply CW with (m:=complexity G)...

    inversion compC...
    apply  HcutG...
 * assert(N=[]).
 simpl in Hj.
   inversion Hj;solveF...
   subst.
    assert( n |--- B ++ [(i0,F)]; M ; (UP L) ->
           j |--- B; []; (DW (Bang i0 (dual F))) ->
             |-- B; M ; (UP L)) as UCCut.
    eapply CH with (m:=h) (C:=Quest i0 F) (dualC:=Bang i0 (dual F));eauto.
    rewrite app_nil_r...
    apply UCCut... LLExact H3.
 *  apply NotAsynchronousPosAtoms in H4...
   apply PositiveDualNegative in H.
     inversion Hj;subst; try match goal with
       [ H: _= dual ?C , H2: negativeFormula (dual ?C) |- _ ] => rewrite <- H in H2
     end;CleanContext.
    assert( n |--- B; M ++ [C]; (UP L) ->
            n0 |--- B; N; (UP [dual C]) ->
             |-- B; M ++ N; (UP L)) as ULCut.
   eapply CH with (m:=n+n0)...
   apply ULCut...
   LLExact H5.
   inversion H...
   inversion Hj...
   apply seqNtoSeq in H5. LLExact H5.
   rewrite <- H7.
   assert(n |--- (i, atom A) :: C; M; (UP L)).
   eapply AbsorptionC...
    LLExact H5.
   apply seqNtoSeq in H0.
   LLExact H0.
   inversion H1.
  * inversion Hj;CleanContext...
   assert( n  |--- B; M; (UP (FX t :: L)) ->
           n0 |--- B; N; (DW (dual (FX t))) ->
              |-- B; M++N; (UP L)) as HCut.
   eapply CW with (m:=complexity (FX (VAR con 0%nat)));eauto...

   inversion compC...
   inversion compC...
    remember (VAR con 0%nat).
            assert(proper e).
            rewrite Heqe.
            constructor.
            eapply ComplexityUniformEq...

            apply HCut...
 Qed.

Theorem CutK4SubCase (h n j w:nat) i a L B P: CutH w h -> CutW w -> complexity P = w -> S h = S n + j -> i <> loc ->
 tri_bangK4 theory n (B ++ [(a, P)]) i [] [] (UP L) ->
 j |--- B; []; (DW (Bang a (dual P))) -> tri_bangK4' theory B i [] [] (UP L).
 Proof with sauto;solveF.
 intros HC WC comP hH Hd Hyp Hj.
        apply InvSubExpPhaseU in Hyp;auto.

        destruct Hyp as [C4 Hyp];
        destruct Hyp as [CK Hyp];
        destruct Hyp as [CN Hyp].
        CleanContext.
        checkPermutationCases H.
        { (* P in C4 *)
         rewrite <- Permutation_cons_append in H8.
         inversion Hj...

         { rewrite H8 in H1...
          assert(False).
          inversion H1...
          solveSignature1.
             contradiction. }
           assert(lt i a /\ m4 a = true /\ SetK4 x /\ LtX i x).
          { rewrite H8 in H1. rewrite H8 in H2.
            inversion H1;inversion H2...  }
          CleanContext.
         finishExponential.

          assert( LtX i CK4).
          { eapply @SetKTrans with (i:=a)... }
          rewrite H in H10.
          change (CK4 ++ CN0) with (CK4 ++ [] ++ CN0) in H10.
          eapply @destructClassicSet' in H10;auto.
          destruct H10 as [K_1 H10].
          destruct H10 as [K_2 H10].
          destruct H10 as [K_3 H10].
          destruct H10 as [K4_1 H10].
          destruct H10 as [K4_2 H10].
          destruct H10 as [K4_3 H10].

          destruct H10 as [N H10].
          simpl in *.
          CleanContext.
          CleanContext.

          assert(Hd': S n0 |--- PlusT CK4; []; (DW (Bang (plust a) (dual P)))).
          { apply BangPlusT...  }
          rewrite H.
          rewrite H25.
          rewrite H28.
            eapply @GenK4RelU' with (C4:=CK4++K4_2) (CK:=CK) (CN:=N)...
          apply Forall_app...
          rewrite H23 in H12...
          apply Forall_app in H12...
          apply Forall_app...
          rewrite H23 in H17...
          apply Forall_app in H17...
          rewrite H25. rewrite H21...
          simplEmpty...
          simplCtx...
  assert(Hp:
 (n - length (C4 ++ CK) - 1) |--- (PlusT CK4 ++ PlusT K4_2 ++ Loc CK) ++ [(plust a,P)]; []; (UP L) ->
   S n0 |--- PlusT CK4 ++ PlusT K4_2 ++ Loc CK; []; (DW (Bang (plust a) (dual P ))) ->
   |-- PlusT CK4 ++ PlusT K4_2 ++ Loc CK; []; (UP L)).

   eapply HC with  (m:=n - length (C4 ++ CK) - 1 + S n0) (C:=Quest (plust a) P) (dualC:=Bang (plust a) (dual P))...
  simpl...

   rewrite app_assoc_reverse...
   apply Hp... all:clear Hp.
   rewrite H25.
   simplCtx...
   repeat rewrite app_assoc_reverse...
   rewrite Permutation_midle_app.
   apply weakeningGenN...
   rewrite app_assoc.
   LLExact H9.
   rewrite <- PlusTApp.
   rewrite <- H23.
   rewrite H8...
   apply weakeningGenN_rev...   }
     checkPermutationCases H8.
          {
           (* P in CK *)
        rewrite <- Permutation_cons_append in H8.
        inversion Hj...
          { rewrite H8 in H3.
             assert(False).
            apply locAlone in Hd.
            apply Hd...
            inversion H3... contradiction. }

          apply InvSubExpPhaseU in H16;auto.

          destruct H16 as [C4' H16].
          destruct H16 as [CK' H16].
          destruct H16 as [CN' H16]...
             assert(lt i a /\ m4 a = false /\ SetK x0 /\ LtX i x0).
          { rewrite H8 in H0;rewrite H8 in H3.
            inversion H0;inversion H3...
            } CleanContext.
          assert(LtX i C4').
          { eapply @SetKTrans with (i:=a)... }
          assert(LtX i CK').
          { eapply @SetKTrans with (i:=a)... }

          rewrite <- H11 in H10.
          rewrite H in H10.
          CleanContext.
          eapply @destructClassicSet' in H10;auto.
          destruct H10 as [K_1 H10].
          destruct H10 as [K_2 H10].
          destruct H10 as [K_3 H10].
          destruct H10 as [K4_1 H10].
          destruct H10 as [K4_2 H10].
          destruct H10 as [K4_3 H10].

          destruct H10 as [N H10].
          simpl in *.
          CleanContext.

           assert(Hd': S n0 |--- PlusT C4' ++ Loc CK'; []; (DW (Bang loc (dual P)))).
          { apply tri_bangL...
            eapply HeightGeqCEx.
            2:{ exact H23. }
            perm.
            lia.
          }

       rewrite H.
      eapply @GenK4RelU' with (C4:=C4'++K4_2) (CK:=x0++K_3) (CN:=N)...
          apply Forall_app...
          rewrite H29 in H1...
          apply Forall_app in H1...
          apply Forall_app...
          rewrite H30 in H12...
          apply Forall_app in H12...
          apply Forall_app...
          rewrite H29 in H2...
          apply Forall_app in H2...
          apply Forall_app...
          rewrite H30 in H26...
          apply Forall_app in H26...
          rewrite H30. rewrite H34...
          rewrite H28...

       assert(Hp:
 (n - length (C4 ++ CK) - 1) |--- (PlusT C4' ++ PlusT K4_2 ++ Loc x0 ++ Loc K_3) ++ [(loc,P)]; []; (UP L) ->
   S n0 |--- (PlusT C4' ++ PlusT K4_2 ++ Loc x0 ++ Loc K_3); []; (DW (Bang loc  (dual P ))) ->
   |-- (PlusT C4' ++ PlusT K4_2 ++ Loc x0 ++ Loc K_3); []; (UP L)).

   eapply HC with  (m:=n - length (C4 ++ CK) - 1 + S n0) (C:=Quest loc P) (dualC:=Bang loc (dual P))...
   CleanContext.
   repeat simplCtx...
   rewrite locApp...
   rewrite app_assoc_reverse.
   apply Hp... all:clear Hp.
   LLPerm(Loc K_3++(PlusT C4' ++ PlusT K4_2 ++ Loc x0) ++ [(loc, P)]).
   apply weakeningGenN...

   rewrite H31.
   simplCtx...
   repeat rewrite app_assoc_reverse.

   rewrite Permutation_midle_app.
   apply weakeningGenN...
   rewrite app_assoc.
   rewrite <- PlusTApp.
   LLExact H9.
   rewrite  H29.
   rewrite H8...
   LLPerm (PlusT K4_2 ++ Loc x0 ++ PlusT C4' ++ Loc K_3).
   apply weakeningGenN...
   rewrite H28.
   rewrite locApp.
    rewrite app_assoc_reverse.
   rewrite Permutation_midle_app.
   apply weakeningGenN...
   LLExact Hd'.
   rewrite H31... rewrite H30... rewrite locApp...  }
  {
        eapply @GenK4RelU' with (C4:=C4) (CK:=CK) (CN:= x0)...
        rewrite <- H10.
        rewrite <- H11...
        HProof.
         }
 Qed.

Theorem CutDwC a j n w h P F L B:
    CutH w h -> CutW w -> S h = n + j -> complexity P = w ->
    j |--- B; []; (DW (Bang a (dual P ))) ->
    n |--- B ++ [(a,P)]; L; (DW F) ->
    |-- B; L; (UP [F]).
  Proof with sauto;solveF.
  intros HC WC Hh Hc Hj Hn.
    inversion Hn...
    * solveLL.
    * checkPermutationCases H5.
      { LLStore. LFocus (perp A). init2 i x. }
      { inversion H2...
        simpl in Hj.
        apply (InvBangT H1 Hj). }
     * solveLL.
   * apply simplUnb in H1.
     apply simplUnb in H2.
     clear H3.
     rewrite <- H1 in H4.
     rewrite <- H2 in H8.
     clear H1 H2.
      assert(CutF: n0 |--- B ++ [(a, P)]; M; (DW F0) ->
             j |--- B; []; (DW (Bang a (dual P ))) ->
             |-- B; M; (UP [F0])).
        eapply HC with (m:=n0 + j) (dualC:=Bang a (dual P)) (C:=Quest a P)...

      assert(CutG: n0 |--- B ++ [(a, P)]; N; (DW G) ->
             j |--- B; []; (DW (Bang a (dual P ))) ->
             |-- B ; N; (UP [G])).
        eapply HC with (m:=n0 + j) (dualC:=Bang a (dual P )) (C:=Quest a P)...
      LLStore. rewrite H0.
      rewrite <- (app_nil_l []).
        eapply @InvTensor with (B:=B) (D:=B)...
    *   assert(n0 |--- B ++ [(a, P)]; L; (DW F0) ->
             j |--- B; []; (DW  (Bang a (dual P ))) ->
             |-- B ; L; (UP [F0])).
        eapply HC with (m:=n0 + j) (dualC:=Bang a (dual P )) (C:=Quest a P)...
        LLStore.
        apply InvPlus...
    *   assert(n0 |--- B ++ [(a, P)]; L; (DW G) ->
             j |--- B; []; (DW  (Bang a (dual P ))) ->
             |-- B ; L; (UP [G])).
        eapply HC with (m:=n0 + j) (dualC:=Bang a (dual P )) (C:=Quest a P)... LLStore.
        apply InvPlusComm...
    *   assert(Hc:
              n0 |--- B ++ [(a,P)]; L; (UP [F]) ->
             j |--- B; []; (DW  (Bang a (dual P ))) ->
               |-- B; L; (UP [F])).

        eapply HC with (m:=n0 + j) (dualC:=Bang a (dual P )) (C:=Quest a P)...
        apply Hc...
   *
   assert(Hc:
              n0 |--- B ++ [(a,P)]; L; (DW (FX t)) ->
             j |--- B; []; (DW  (Bang a (dual P ))) ->
               |-- B; L; (UP [FX t])).

        eapply HC with (m:=n0 + j) (dualC:=Bang a (dual P )) (C:=Quest a P)...
       LLStore.
        eapply InvEx with (t:=t)...
    *
        assert(Hc:
            n0 |--- B ++ [(a,P)]; []; (UP [F0]) ->
             j |--- B; []; (DW  (Bang a (dual P ))) ->
               |-- B; []; (UP [F0])).

        eapply HC with (m:=n0 + j) (dualC:=Bang a (dual P )) (C:=Quest a P)...
        exact nil.
        LLStore.
        LFocus (Bang loc F0).
    *  LLStore. LFocus (Bang i F0).
       createWorld.
       eapply @CutK4SubCase with (n:=n0) (j:=j) (h:=h) (P:=P) (a:=a) (w:=complexity P) (B:=B)...

  Qed.

 Theorem CutUPC  i j w h a A L M B  : CutH w h -> CutW w -> complexity A = w -> S h = i + j ->
  i |--- B++[(a,A)]; M; (UP L) ->
  j |--- B; []; (DW (Bang a (dual A ))) ->
  |-- B; M; (UP L).
Proof with sauto;try solveLL.
  intros CH CW compA hH Hi Hj.
  inversion Hi...
  --  assert( n |--- B ++ [(a,A)]; M; (UP M0) ->
              j |--- B; []; (DW  (Bang a (dual A ))) -> |-- B; M; (UP M0)) as Cut.
              eapply CH with (C:=Quest a A ) (dualC:=Bang a (dual A))...
              apply Cut...
  --  assert( n |--- B ++ [(a,A)]; M; (UP (F :: G :: M0)) ->
              j |--- B; []; (DW  (Bang a (dual A ))) -> |-- B; M; (UP (F :: G ::M0))) as Cut.
              eapply CH with (C:=Quest a A ) (dualC:=Bang a (dual A))...
              apply Cut...
  --  assert( n |--- B ++ [(a,A)]; M; (UP (F :: M0)) ->
              j |--- B; []; (DW  (Bang a (dual A ))) -> |-- B; M; (UP (F :: M0))) as Cut.
              eapply CH with (C:=Quest a A ) (dualC:=Bang a (dual A))...
              apply Cut...
  --  assert( n |--- B ++ [(a,A)]; M; (UP (G :: M0)) ->
              j |--- B; []; (DW  (Bang a (dual A ))) -> |-- B; M; (UP (G ::M0))) as Cut.
              eapply CH with (C:=Quest a A ) (dualC:=Bang a (dual A))...
              apply Cut...
  --  assert( n |--- (B ++ [(i0, F)]) ++ [(a,A)]; M; (UP M0) ->
              j |--- B ++ [(i0, F)]; []; (DW  (Bang a (dual A ))) -> |-- B ++ [(i0, F)]; M; (UP M0)) as Cut.
              eapply CH with (C:=Quest a A ) (dualC:=Bang a (dual A))...
              LLPerm(B  ++ [(i0, F)])...
              apply Cut...
              LLExact H3.
              apply weakeningGenN_rev...
  --  assert( n |--- B ++ [(a,A)]; F::M ; (UP M0) ->
              j |--- B; []; (DW  (Bang a (dual A ))) -> |-- B ; F::M; (UP M0)) as Cut.
              eapply CH with (C:=Quest a A ) (dualC:=Bang a (dual A))...
              apply Cut...
  -- assert( n |--- B ++ [(a,A)]; L'; (DW F) ->
             j |--- B; []; (DW (Bang a (dual A ))) -> |-- B ; L'; (UP [F])) as Cut.
     eapply CH with (C:=Quest a A ) (dualC:=Bang a (dual A))...
     assert( |-- B ; L'; (UP [F])).
     apply Cut...
     rewrite <- H1.
     inversion H;solveF...
  --  apply in_app_or in H3...
      +   assert( n |--- B ++ [(a,A)]; M; (DW F) ->
          j |--- B; []; (DW  (Bang a (dual A ))) -> |-- B ; M; (UP [F])) as Cut.
          eapply CH with  (C:=Quest a A ) (dualC:=Bang a (dual A))...
          eapply @AbsorptionClassic with (i:=i0) (F:=F)...
      + inversion H...
        assert( n |--- B ++ [(i0,F)]; M; (DW F) ->
          j |--- B; []; (DW  (Bang i0 (dual F ))) -> |-- B ; M; (UP [F])) as Cut.
          eapply CH with (C:=Quest i0 F ) (dualC:=Bang i0 (dual F))...
          assert(Hs: |-- B; M; (UP [F]))...
          clear Cut.
          apply seqtoSeqN in Hs.
          destruct Hs as [x Hs].
          apply InvBangT in Hj...
         apply seqtoSeqN in Hj.
          destruct Hj as [y Hj].

            destruct(PositiveOrNegative F).
            assert(negativeFormula (F ^)).
            apply PositiveDualNegative...

            assert( x |--- B; M ; (UP [F]) ->
                    S y |--- B; []; (DW (dual F)) ->
                      |-- B; M++[] ; UP [ ]) as Cut.
            eapply CW with (m:=complexity F)...
            CleanContext.

            assert( y |--- B; [] ; (UP [dual F]) ->
                  S x |--- B; M; (DW F) ->
                      |-- B; []++M ; UP [ ]) as Cut.
            eapply CW with (m:=complexity F)...
            rewrite <- ng_involutive...
            CleanContext.
   -- rewrite allU in H0...
   -- assert(n |--- B ++ [(a, A)]; M; (DW F) ->
                    j |--- B; []; (DW (Bang a (dual A ))) ->
                      |-- B; M ; UP [F]) as Cut.
            eapply CH with  (C:=Quest a A ) (dualC:=Bang a (dual A))...
           assert(Hs:|--B; M; (UP [F])).
           apply Cut...
             destruct (NegativeAtomDec F).
              2:{  eapply @AbsorptionTheory with (F:=F)... }

             inversion H...
             eapply @AbsorptionPerp' with (A:=A0)...
  --  assert( n |--- B ++ [(a,A)]; M; (UP (FX x ::  M0)) ->
              j |--- B; []; (DW (Bang a (dual A ))) -> |-- B ; M; (UP (FX x :: M0))) as Cut.
              eapply CH with (C:=Quest a A ) (dualC:=Bang a (dual A))...
              apply Cut...
  -- createWorld i0.
   eapply @CutK4SubCase with (n:=n) (j:=j) (h:=h) (P:=A) (a:=a) (w:=complexity A) (B:=B)...
   solveSignature1.
  Qed.

  Theorem CutElimination i j a C dualC A dualA B L M N P:
    dualC = dual C ->
      (i |--- B; M ++ [C]; (UP L) -> j |--- B; N; (UP [dualC]) -> |-- B; M ++ N; (UP L)) /\
      (i |--- B; M; (UP (C :: L)) -> j |--- B; N; (DW dualC) -> |-- B; M ++ N; (UP L)) /\
       (dualA = A ^ ->
       dualC = Bang a dualA ->
       i |--- B ++ [(a,A)] ; M; (DW P) -> j |--- B; []; (DW (Bang a dualA)) -> |-- B; M; (UP [P]))  /\
      (dualA = A ^ ->
       dualC = Bang a dualA ->
       i |--- B ++ [(a,A)] ; M; (UP L) -> j |--- B; []; (DW (Bang a dualA)) -> |-- B; M; (UP L)).
  Proof with sauto;solveF;try solveLL.
    assert(exists w, complexity C = w).
    eexists; auto.
    destruct H as [w H].
    revert H.
    revert a i j C dualC A dualA P B L M N.

    induction w using strongind;intros.
    - assert(complexity C > 0) by apply Complexity0.
      rewrite H in H1. inversion H1.
    - remember (plus i j) as h.
      revert dependent B.
      revert dependent L.
      revert dependent M.
      revert dependent N.
      revert dependent P.
      revert dependent dualA.

      revert A.
      revert dependent C.
      revert dependent dualC.

      revert dependent i.
      revert a j.
      dependent induction h using strongind; intros.
      +
        symmetry in Heqh.
        apply plus_is_O in Heqh.
        destruct Heqh;subst.
        eapply CutElimBase...

      + rename H into CutW.
        rename H0 into CutH.
        rename H1 into compC.

        move B at top.
        move M at top.
        move N at top.
        move L at top.
        move C at top.
        move A at top.
        move dualC at top.
        move dualA at top.
        move P at top.
        subst.
        split;[intros
              |split;[intros
              |split;intros]].
       *  eapply (@CutUPLStar i j w h C L M N B)...
          unfold CutElimination.CutH; intros.
          eapply CutH with (m:=m)...
        * eapply (@CutUP i j w h C L M N B)...
           unfold CutElimination.CutH; intros.
           eapply CutH with (m:=m)...
           unfold CutElimination.CutW; intros.
           eapply CutW with (m:=m)...
        * eapply (@CutDwC a j i w h A P M B)...
           unfold CutElimination.CutH; intros.
          eapply CutH with (m:=m)...
           unfold CutElimination.CutW; intros.
          eapply CutW with (m:=m)...
          rewrite DualComplexity in compC...
              rewrite H0 in compC...
              inversion compC...
        * eapply (@CutUPC i j w h a A L M B)...
           unfold CutElimination.CutH; intros.
          eapply CutH with (m:=m)...
           unfold CutElimination.CutW; intros.
          eapply CutW with (m:=m)...
         rewrite DualComplexity in compC...
              rewrite H0 in compC...
              inversion compC...
 Qed.

  Theorem GeneralCut i j C B L M N:
    (i |--- B; M ; UP (C::L) ->
                   j |--- B; N ; DW (dual C) ->
                                 |-- B; M++N ; UP L).
  Proof with subst;auto.
    intros.
    assert(exists w, complexity C = w).
    eexists; auto.
    destruct H1 as [w H1].
    specialize CutElimination;intros.
    assert((i |--- B; M ; UP (C::L) ->
                          j |--- B; N ; DW (dual C) ->
                                        |-- B; M++N ; UP L)) as CUT.
    eapply H2;eauto.

    clear H2.
    apply CUT;auto.
  Qed.

  Theorem GeneralCutClassic i j a A B L M:
    (i |--- B ++ [(a,A)] ; M; (UP L) ->
            j |--- B; []; (DW (Bang a (dual A))) ->
                  |-- B; M; (UP L)).
  Proof with subst;auto.
    intros.
    assert(exists w, complexity A = w).
    eexists; auto.
    destruct H1 as [w H1].
    specialize CutElimination;intros.
    assert((i |--- B ++ [(a,A)]; M ; UP L ->
                          j |--- B; [] ; DW (Bang a (dual A)) ->
                                        |-- B; M ; UP L)) as CUT.
    eapply H2 with (C:=Quest a A) ;eauto.
    clear H2.
    apply CUT;auto.
  Qed.

    Theorem GeneralCutClassic' a A B L M:
    (|-- B ++ [(a,A)] ; M; (UP L) -> |-- B; []; (DW (Bang a (dual A))) -> |-- B; M; (UP L)).
  Proof with subst;auto.
    intros.
    apply seqtoSeqN in H0.
    apply seqtoSeqN in H.
    CleanContext.
    eapply GeneralCutClassic;eauto.
  Qed.

  Theorem GeneralCut' C B L M N:
    (|-- B; M ; UP (C::L) ->
                   |-- B; N ; DW (dual C) ->
                                 |-- B; M++N ; UP L).
  Proof with subst;auto.
    intros.
    apply seqtoSeqN in H0.
    apply seqtoSeqN in H.
    CleanContext.
    eapply GeneralCut;eauto.
  Qed.

End CutElimination.


Require Import Relations.
Require Import EquivDec.
Require Import Equality.
Require Import List.
Require Import Bool.
Require Import Lia.
Require Import NArith.
Require Import PArith.
Require Import ZArith.
Require Import FMapPositive.
Require Import FSetPositive.
Require Import sflib.
Require Import HahnRelationsBasic.

Require Import PromisingArch.lib.Basic.
Require Import PromisingArch.lib.Order.
Require Import PromisingArch.lib.Time.
Require Import PromisingArch.lib.Lang.
Require Import PromisingArch.promising.CommonPromising.
Require Import PromisingArch.promising.TsoPromising.
Require Import PromisingArch.equiv.TsoPtoPF.

Set Implicit Arguments.

(* simulation relations *)

Inductive sim_memory (n: nat) (mem_pf mem_v: Memory.t): Prop :=
| sim_memory_intro
    mem_post
    (MEMORY: mem_pf = mem_v ++ mem_post)
    (LENGTH: List.length mem_v = n)
.
Hint Constructors sim_memory.

Inductive sim_local (n: nat) (lc_pf lc_v: Local.t): Prop :=
| sim_local_intro
    (COH: lc_pf.(Local.coh) = lc_v.(Local.coh))
    (VRN: lc_pf.(Local.vrn) = lc_v.(Local.vrn))
    (VPR: lc_pf.(Local.vpr) = lc_v.(Local.vpr))
    (VPA: lc_pf.(Local.vpa) = lc_v.(Local.vpa))
    (VPC: lc_pf.(Local.vpc) = lc_v.(Local.vpc))
    (PROMISES_PF: forall ts (PROMISE: Promises.lookup ts lc_pf.(Local.promises) = true), ts > n)
    (PROMISES_V: lc_v.(Local.promises) = fun _ => false)
.
Hint Constructors sim_local.

Inductive sim_sl (n: nat) (sl_pf sl_v: State.t (A:=unit) * Local.t): Prop :=
| sim_sl_intro
    (STATE: fst sl_pf = fst sl_v)
    (LOCAL: sim_local n (snd sl_pf) (snd sl_v))
.
Hint Constructors sim_sl.

Inductive sim (n: nat) (m_pf m_v: Machine.t): Prop :=
| sim_intro
    (TPOOL: forall tid, opt_rel (sim_sl n)
                           (IdMap.find tid m_pf.(Machine.tpool))
                           (IdMap.find tid m_v.(Machine.tpool)))
    (MEMORY: sim_memory n m_pf.(Machine.mem) m_v.(Machine.mem))
.
Hint Constructors sim.

Definition promises_le (tid: Id.t) (promises: Promises.t) (mem: Memory.t): Prop :=
  forall ts (LOOKUP: Promises.lookup ts promises = true),
  exists loc val, Memory.get_msg ts mem = Some (Msg.mk loc val tid).

Inductive promises_wf (n: nat) (m: Machine.t): Prop :=
| promises_wf_intro
    (SOUND: forall tid st lc
              (FIND: IdMap.find tid m.(Machine.tpool) = Some (st, lc)),
        <<LE: promises_le tid lc.(Local.promises) m.(Machine.mem)>>)
    (COMPLETE: forall ts loc val tid
           (GT: n < ts)
           (GET: Memory.get_msg ts m.(Machine.mem) = Some (Msg.mk loc val tid)),
        exists st lc,
          (<<FIND: IdMap.find tid m.(Machine.tpool) = Some (st, lc)>>) /\
          (<<IN: Promises.lookup ts lc.(Local.promises) = true>>))
.
Hint Constructors promises_wf.

Lemma sim_memory_latest
      n mem_pf mem_v loc from to
      (SIM: sim_memory n mem_pf mem_v)
      (TO: to <= n)
      (LATEST: Memory.latest loc from to mem_pf):
  Memory.latest loc from to mem_v.
Proof.
  inv SIM. ii. exploit LATEST; eauto.
  rewrite nth_error_app1; ss. nia.
Qed.

Lemma sim_memory_read
      n mem_pf mem_v loc ts val
      (SIM: sim_memory n mem_pf mem_v)
      (TS: ts <= n)
      (READ: Memory.read loc ts mem_pf = val):
  Memory.read loc ts mem_v = val.
Proof.
  inv SIM. unfold Memory.read in *.
  destruct ts; ss.
  des_ifs; rewrite nth_error_app1 in *; try nia; congr.
Qed.

Lemma sim_memory_exclusive
      n mem_pf mem_v tid loc val from
      (SIM: sim_memory n mem_pf mem_v)
      (LENGTH: length mem_pf > n)
      (FROM: from < n + 1)
      (EXCLUSIVE: Memory.exclusive tid loc from (n + 1) mem_pf):
  Memory.exclusive tid loc from (n + 1) (mem_v ++ [Msg.mk loc val tid]).
Proof.
  inv SIM. ii. des.
  exploit EXCLUSIVE; eauto.
  destruct (classic (ts = length mem_v)).
  { subst. rewrite nth_error_app2 in MSG; try nia.
    rewrite Nat.sub_diag in MSG. ss. inv MSG. rewrite <- H1 in *. ss. }
  rewrite nth_error_app1 in *; try nia. ss.
Qed.

Lemma sim_local_last
      tid lc_pf lc_v mem_pf
      (SIM: sim_local (length mem_pf) lc_pf lc_v)
      (WF: Local.wf tid mem_pf lc_pf):
  lc_pf = lc_v.
Proof.
  destruct lc_pf, lc_v.
  inv SIM. inv WF. ss. subst. f_equal.
  apply Promises.ext. i.
  destruct (Promises.lookup i promises) eqn:GET.
  - exploit PROMISES; eauto. i.
    exploit PROMISES_PF; eauto. i. nia.
  - unfold Promises.lookup, bot, fun_bot. condtac; ss.
Qed.

Lemma sim_memory_last
      mem_pf mem_v
      (SIM: sim_memory (length mem_pf) mem_pf mem_v):
  mem_pf = mem_v.
Proof.
  inv SIM. destruct mem_post.
  - rewrite app_nil_r. ss.
  - rewrite app_length in *. ss. nia.
Qed.

Lemma sim_last
      m_pf m_v
      (SIM: sim (length m_pf.(Machine.mem)) m_pf m_v)
      (WF: Machine.wf m_pf):
  Machine.equiv m_pf m_v.
Proof.
  inv SIM. exploit sim_memory_last; eauto. i.
  econs; ss.
  ii. specialize (TPOOL y). inv TPOOL; ss.
  destruct a, b. symmetry in H0, H. inv REL. ss. subst.
  inv WF. exploit WF0; try eapply H0. i. inv x.
  exploit sim_local_last; eauto. s. i. subst. ss.
Qed.

Lemma sim_local_refl
      n lc
      (PROMISES: lc.(Local.promises) = bot):
  sim_local n lc lc.
Proof.
  econs; i; try refl.
  - rewrite PROMISES in *.
    unfold Promises.lookup, bot, fun_bot in *. des_ifs.
  - rewrite PROMISES in *. ss.
Qed.

Lemma sim_memory_refl mem:
  sim_memory (length mem) mem mem.
Proof.
  econs; ss.
  rewrite app_nil_r. ss.
Qed.

Lemma init_sim p:
  (<<SIM: sim 0 (Machine.init p) (Machine.init p)>>) /\
  (<<PROMISES_WF: promises_wf 0 (Machine.init p)>>).
Proof.
  split; unnw.
  - unfold Machine.init. econs; ss.
    + i. rewrite IdMap.map_spec.
      destruct (IdMap.find tid p); ss. econs. econs; ss. econs; ss. i.
      unfold Promises.lookup, bot, fun_bot in *. des_ifs.
    + econs; ss.
  - econs; ii.
    + revert FIND. unfold Machine.init. s. rewrite IdMap.map_spec.
      destruct (IdMap.find tid p); ss. i. inv FIND.
      unfold Promises.lookup, bot, fun_bot in *. des_ifs.
    + ss. unfold Memory.get_msg in *. des_ifs. destruct t; ss.
Qed.

Lemma promise_step_sim
      n m1_pf m2_pf m_v
      (SIM1: sim n m1_pf m_v)
      (STEP: Machine.step ExecUnit.promise_step m1_pf m2_pf):
  sim n m2_pf m_v.
Proof.
  inv SIM1. inv STEP. inv STEP0. ss. subst. inv LOCAL.
  econs; i.
  - rewrite TPOOL0. rewrite IdMap.add_spec. condtac; ss.
    rewrite e in *. specialize (TPOOL tid). rewrite FIND in *. inv TPOOL.
    destruct b as [st lc]. inv REL. ss. econs. econs; ss.
    inv LOCAL. econs; ss. i. revert PROMISE.
    rewrite Promises.set_o. condtac; ss; eauto. i.
    rewrite e0 in *. unfold Memory.append in *. inv MEM2.
    inv MEMORY. rewrite MEMORY0. rewrite app_length. nia.
  - inv MEMORY. unfold Memory.append in *. inv MEM2. econs; ss.
    rewrite MEMORY0. rewrite <- app_assoc. refl.
Qed.

Lemma promise_step_promises_wf
      n m1 m2
      (WF1: promises_wf n m1)
      (STEP: Machine.step ExecUnit.promise_step m1 m2):
  promises_wf n m2.
Proof.
  inv WF1. inv STEP. inv STEP0. ss. subst. inv LOCAL.
  econs; ii.
  - revert FIND0. rewrite TPOOL. rewrite IdMap.add_spec. condtac; ss.
    + rewrite e in *. i. inv FIND0. ss.
      revert LOOKUP. rewrite Promises.set_o. condtac; ss.
      * i. rewrite e0 in *. inv MEM2.
        unfold Memory.get_msg. ss.
        rewrite nth_error_last. esplits; eauto.
      * i. inv MEM2. exploit SOUND; eauto. i. des.
        unfold Memory.get_msg in *. destruct ts0; ss.
        rewrite nth_error_app1; eauto.
        exploit nth_error_some; eauto.
    + i. exploit SOUND; eauto. i. des. inv MEM2.
      unfold Memory.get_msg in *. destruct ts0; ss.
      rewrite nth_error_app1; eauto.
      exploit nth_error_some; eauto.
  - inv MEM2. rewrite <- H1 in *.
    unfold Memory.get_msg in *. destruct ts0; ss.
    destruct (classic (ts0 = length m1.(Machine.mem))).
    + rewrite H in *. rewrite nth_error_last in GET. inv GET.
      rewrite TPOOL. rewrite IdMap.gss. esplits; eauto. s.
      rewrite Promises.set_o. condtac; ss. congr.
    + exploit nth_error_some; eauto. rewrite app_length. s. i.
      rewrite nth_error_app1 in GET by nia.
      exploit COMPLETE; eauto. i. des.
      rewrite TPOOL. rewrite IdMap.add_spec. condtac; ss; eauto.
      rewrite e in *. rewrite FIND in *. inv FIND0.
      esplits; eauto. s.
      rewrite Promises.set_o. condtac; eauto.
Qed.

Lemma rtc_promise_step_sim
      n m1_pf m2_pf m_v
      (SIM1: sim n m1_pf m_v)
      (WF1: promises_wf n m1_pf)
      (STEP: rtc (Machine.step ExecUnit.promise_step) m1_pf m2_pf):
  (<<SIM2: sim n m2_pf m_v>>) /\
  (<<PROMISES_WF2: promises_wf n m2_pf>>).
Proof.
  dependent induction STEP; eauto using promise_step_sim, promise_step_promises_wf.
Qed.

(* next fulfillment *)

Definition is_writing (e: Event.t (A:=unit)): bool :=
  match e with
  | Event.write _ _ _ _ _
  | Event.rmw _ _ _ _ _  => true
  | _ => false
  end.

Lemma non_fulfillable
      tid st1 lc1 st lc mem ts loc
      (STEPS: rtc (ExecUnit.state_step tid)
                  (ExecUnit.mk st1 lc1 mem)
                  (ExecUnit.mk st lc mem))
      (PROMISE: Promises.lookup ts lc1.(Local.promises) = true)
      (PROMISES_BOT: lc.(Local.promises) = bot)
      (COH: ts <= (lc1.(Local.coh) loc).(View.ts)):
  False.
Proof.
  revert PROMISE COH. dependent induction STEPS; i.
  { rewrite PROMISES_BOT in *.
    unfold Promises.lookup, bot, fun_bot in *. des_ifs. }
  exploit ExecUnit.state_step_incr; eauto. i.
  destruct y. inv H. inv STEP. ss. subst.
  apply (IHSTEPS state local st lc mem); eauto.
  - inv LOCAL; try inv STEP; ss.
    + rewrite Promises.unset_o. condtac; ss. rewrite e in *.
      inv WRITABLE. inv COHMAX.
      exploit le_lt_trans; [eapply (MAX loc)|eapply EXT|]. i. nia.
    + rewrite Promises.unset_o. condtac; ss. rewrite e in *.
      inv WRITABLE. inv COHMAX.
      exploit le_lt_trans; [eapply (MAX loc)|eapply EXT|]. i. nia.
  - inv x0. inv LC. ss. etrans; eauto. apply COH0.
Qed.

Lemma next_fulfill_exists_eu
      tid st1 lc1 st lc mem ts
      (STEPS: rtc (ExecUnit.state_step tid)
                  (ExecUnit.mk st1 lc1 mem)
                  (ExecUnit.mk st lc mem))
      (PROMISE: Promises.lookup ts lc1.(Local.promises) = true)
      (PROMISES_TS: forall ts' (GET: Promises.lookup ts' lc1.(Local.promises) = true), ts' >= ts)
      (BOT: lc.(Local.promises) = bot):
  exists st2 lc2,
    (<<STEPS: rtc (ExecUnit.state_step tid)
                  (ExecUnit.mk st1 lc1 mem)
                  (ExecUnit.mk st2 lc2 mem)>>) /\
    ((exists st3 lc3 ord vloc vval res,
         (<<STEP_ST: State.step (Event.write false ord vloc vval res) st2 st3>>) /\
         (<<STEP_LC: Local.fulfill vloc vval res ts tid lc2 mem lc3>>) /\
         (<<PROMISES: lc3.(Local.promises) = Promises.unset ts lc1.(Local.promises)>>) /\
         (<<STEPS_POST: rtc (ExecUnit.state_step tid)
                            (ExecUnit.mk st3 lc3 mem)
                            (ExecUnit.mk st lc mem)>>)) \/
     (exists st3 lc3 ordr ordw vloc vold vnew old_ts,
         (<<STEP_ST: State.step (Event.rmw ordr ordw vloc vold vnew) st2 st3>>) /\
         (<<STEP_LC: Local.rmw vloc vold vnew old_ts ts tid lc2 mem lc3>>) /\
         (<<PROMISES: lc3.(Local.promises) = Promises.unset ts lc1.(Local.promises)>>) /\
         (<<STEPS_POST: rtc (ExecUnit.state_step tid)
                            (ExecUnit.mk st3 lc3 mem)
                            (ExecUnit.mk st lc mem)>>))).
Proof.
  dependent induction STEPS; i.
  { rewrite BOT in *.
    unfold Promises.lookup, bot, fun_bot in *.
    des_ifs. }
  destruct y. dup H. inv H0. inv STEP. ss. subst.
  destruct (is_writing e) eqn:EVENT; cycle 1.
  { assert (local.(Local.promises) = lc1.(Local.promises)).
    { destruct e; ss; try (inv LOCAL; ss); inv STEP; ss. }
    exploit (IHSTEPS state local st lc mem); eauto; try congr.
    { destruct e; ss; try (inv LOCAL; ss); inv STEP; ss. }
    i. des.
    - esplits.
      + econs 2; eauto.
      + left. esplits; eauto. congr.
    - esplits.
      + econs 2; eauto.
      + right. esplits; eauto. congr.
  }

  destruct e; ss.
  - inv LOCAL; ss. inv EVENT0.
    destruct (classic (ts0 = ts)).
    { subst. esplits; try refl. left. esplits; eauto. inv STEP. ss. }
    exfalso. eapply (@non_fulfillable _ _ _ _ _ _ ts vloc0.(ValA.val)); eauto.
    + inv STEP. s. rewrite Promises.unset_o. condtac; ss. congr.
    + inv STEP. s. rewrite fun_add_spec_eq. ss.
      exploit PROMISES_TS; try exact PROMISE0. i. ss.
  - inv LOCAL; ss. inv EVENT0.
    destruct (classic (ts0 = ts)).
    { subst. esplits; try refl. right. esplits; eauto. inv STEP. ss. }
    exfalso. eapply (@non_fulfillable _ _ _ _ _ _ ts vloc0.(ValA.val)); eauto.
    + inv STEP. s. rewrite Promises.unset_o. condtac; ss. congr.
    + inv STEP. s. rewrite fun_add_spec_eq. ss.
      exploit PROMISES_TS; try exact PROMISE0. i. ss.
Qed.

Lemma next_fulfill_exists
      n m1 m m1_v
      (SIM: sim n m1 m1_v)
      (EXEC1: Machine.state_exec m1 m)
      (N: n < length m1.(Machine.mem))
      (PROMISES1: promises_wf n m1)
      (PROMISES_BOT: Machine.no_promise m):
  exists tid st1 lc1 st2 lc2,
    (<<FIND: IdMap.find tid m1.(Machine.tpool) = Some (st1, lc1)>>) /\
    (<<STEPS: rtc (ExecUnit.state_step tid)
                  (ExecUnit.mk st1 lc1 m1.(Machine.mem))
                  (ExecUnit.mk st2 lc2 m1.(Machine.mem))>>) /\
    __guard__ (
        (exists st3 lc3 ord vloc vval res m2,
            (<<STEP_ST: State.step (Event.write false ord vloc vval res) st2 st3>>) /\
            (<<STEP_LC: Local.fulfill vloc vval res (n + 1) tid lc2 m1.(Machine.mem) lc3>>) /\
            (<<MACHINE2: m2 = Machine.mk (IdMap.add tid (st3, lc3) m1.(Machine.tpool)) m1.(Machine.mem)>>) /\
            (<<EXEC2: Machine.state_exec m2 m>>) /\
            (<<PROMISES2: promises_wf (n + 1) m2>>)) \/
        (exists st3 lc3 ordr ordw vloc vold vnew old_ts m2,
            (<<STEP_ST: State.step (Event.rmw ordr ordw vloc vold vnew) st2 st3>>) /\
            (<<STEP_LC: Local.rmw vloc vold vnew old_ts (n + 1) tid lc2 m1.(Machine.mem) lc3>>) /\
            (<<MACHINE2: m2 = Machine.mk (IdMap.add tid (st3, lc3) m1.(Machine.tpool)) m1.(Machine.mem)>>) /\
            (<<EXEC2: Machine.state_exec m2 m>>) /\
            (<<PROMISES2: promises_wf (n + 1) m2>>))).
Proof.
  unguard.
  destruct m1 as [tpool1 mem]. dup EXEC1. inv EXEC0. ss.
  destruct (Memory.get_msg (n + 1) mem) as [[]|] eqn:GET; cycle 1.
  { unfold Memory.get_msg in *. rewrite Nat.add_1_r in *. ss.
    exploit nth_error_None. i. des.
    exploit x0; eauto. i. nia. }
  dup PROMISES1. inv PROMISES0.
  exploit COMPLETE; try exact GET; try nia. s. i. des.
  specialize (TPOOL tid). inv TPOOL; try congr.
  rewrite FIND in *. inv H0.
  destruct b as [st_end lc_end]. ss.
  exploit next_fulfill_exists_eu; eauto.
  { inv SIM. specialize (TPOOL tid). inv TPOOL; try congr.
    rewrite FIND in *. inv H1. inv REL0. inv LOCAL. ss.
    i. exploit PROMISES_PF; eauto. i. nia. }
  { inv PROMISES_BOT. eauto. }
  i. des.
  - esplits; eauto. left. esplits; eauto.
    + econs; ss. ii.
      rewrite IdMap.add_spec. condtac; ss.
      * rewrite <- e in *. rewrite <- H. econs. ss.
      * inv EXEC1. ss.
    + inv PROMISES1. econs; s; i; unnw.
      * revert FIND0. rewrite IdMap.add_spec. condtac; eauto.
        i. inv FIND0. rewrite e in *. rewrite PROMISES. ii.
        revert LOOKUP. rewrite Promises.unset_o. condtac; ss. i.
        eapply SOUND0; eauto.
      * exploit COMPLETE0; try exact GET0; try by nia. i. des.
        rewrite IdMap.add_spec. condtac; ss; eauto.
        rewrite e, FIND in *. inv x. esplits; eauto.
        rewrite PROMISES. rewrite Promises.unset_o. condtac; ss.
        rewrite e0 in *. nia.
  - esplits; eauto. right. esplits; eauto.
    + econs; ss. ii.
      rewrite IdMap.add_spec. condtac; ss.
      * rewrite <- e in *. rewrite <- H. econs. ss.
      * inv EXEC1. ss.
    + inv PROMISES1. econs; s; i; unnw.
      * revert FIND0. rewrite IdMap.add_spec. condtac; eauto.
        i. inv FIND0. rewrite e in *. rewrite PROMISES. ii.
        revert LOOKUP. rewrite Promises.unset_o. condtac; ss. i.
        eapply SOUND0; eauto.
      * exploit COMPLETE0; try exact GET0; try by nia. i. des.
        rewrite IdMap.add_spec. condtac; ss; eauto.
        rewrite e, FIND in *. inv x. esplits; eauto.
        rewrite PROMISES. rewrite Promises.unset_o. condtac; ss.
        rewrite e0 in *. nia.
Qed.

(* simulating eu steps *)

Lemma sim_step
      n
      e tid lc1_pf lc2_pf mem_pf
      lc1_v mem_v
      (LOCAL1: sim_local n lc1_pf lc1_v)
      (MEMORY: sim_memory n mem_pf mem_v)
      (WF1_PF: Local.wf tid mem_pf lc1_pf)
      (WF1_V: Local.wf tid mem_v lc1_v)
      (STEP_PF: Local.step e tid mem_pf lc1_pf lc2_pf):
  (exists lc2_v,
      (<<STEP_V: Local.view_step e tid mem_v mem_v lc1_v lc2_v>>) /\
      (<<LOCAL2: sim_local n lc2_pf lc2_v>>) /\
      (<<PROMISES_PF: lc2_pf.(Local.promises) = lc1_pf.(Local.promises)>>)) \/
  (exists loc,
      <<COH: (lc2_pf.(Local.coh) loc).(View.ts) > n>>).
Proof.
  destruct lc1_pf as [coh_pf vrn_pf vpa_pf per_pf promises_pf].
  destruct lc1_v as [coh_v vrn_v vpa_v per_v promises_v].
  dup LOCAL1. inv LOCAL0. ss. subst.
  inv STEP_PF.
  - (* internal *)
    left. esplits; eauto. econs 1; ss.
  - (* read *)
    destruct (classic (ts <= n)).
    + inv STEP. ss. left. esplits.
      * econs 2; eauto. econs; s; eauto.
        { eapply sim_memory_latest; eauto.
          inv WF1_V. inv MEMORY; ss. }
        { eapply sim_memory_read; eauto. }
      * eauto.
      * ss.
    + inv STEP. ss. right. exists vloc.(ValA.val).
      funtac. apply not_le. ss.
  - (* fulfill *)
    inv STEP. ss. exploit PROMISES_PF; eauto. i.
    right. exists vloc.(ValA.val).
    rewrite fun_add_spec_eq. ss.
  - (* rmw *)
    inv STEP. ss. exploit PROMISES_PF; eauto. i.
    right. exists vloc.(ValA.val).
    rewrite fun_add_spec_eq. ss.
  - (* rmw failure *)
    destruct (classic (old_ts <= n)).
    + inv STEP. ss. left. esplits.
      * econs 5; eauto. econs; s; eauto.
        { eapply sim_memory_latest; eauto.
          inv WF1_V. inv MEMORY. ss. }
        { eapply sim_memory_read; eauto. }
      * eauto.
      * ss.
    + inv STEP. ss. right. exists vloc.(ValA.val).
      funtac. apply not_le. ss.
  - (* mfence *)
    left. inv STEP. inv COHMAX. ss. esplits.
    + econs 6; eauto. econs; eauto.
    + eauto.
    + ss.
  - (* sfence *)
    left. inv STEP. inv COHMAX. ss. esplits.
    + econs 7; eauto. econs; eauto.
    + eauto.
    + ss.
  - (* flush *)
    left. inv STEP. inv COHMAX. ss. esplits.
    + econs 8; eauto. econs; eauto; econs; ss.
    + eauto.
    + ss.
  - (* flushopt *)
    left. inv STEP. ss. esplits.
    + econs 9; eauto. econs; eauto. econs.
    + eauto.
    + ss.
Qed.

Lemma sim_fulfill
      n tid
      vloc vval res lc1_pf mem_pf lc2_pf
      lc1_v mem1_v
      (LOCAL1: sim_local n lc1_pf lc1_v)
      (MEMORY1: sim_memory n mem_pf mem1_v)
      (WF1_PF: Local.wf tid mem_pf lc1_pf)
      (WF1_V: Local.wf tid mem1_v lc1_v)
      (STEP_PF: Local.fulfill vloc vval res (n + 1) tid lc1_pf mem_pf lc2_pf):
  exists lc2_v mem2_v,
    (<<STEP_V: Local.write vloc vval res (n + 1) tid lc1_v mem1_v lc2_v mem2_v>>) /\
    (<<LOCAL2: sim_local (n + 1) lc2_pf lc2_v>>) /\
    (<<MEMORY2: sim_memory (n + 1) mem_pf mem2_v>>) /\
    (<<PROMISES_PF: lc2_pf.(Local.promises) = Promises.unset (n + 1) lc1_pf.(Local.promises)>>).
Proof.
  destruct lc1_pf as [coh_pf vrn_pf vpa_pf per_pf promises_pf].
  destruct lc1_v as [coh_v vrn_v vpa_v per_v promises_v].
  inv LOCAL1. inv MEMORY1. inv STEP_PF. ss. subst.
  esplits.
  - econs; eauto.
    unfold Memory.append. rewrite Nat.add_1_r. refl.
  - econs; eauto; s. i.
    revert PROMISE0. rewrite Promises.unset_o. condtac; ss. i.
    exploit PROMISES_PF; eauto. i.
    destruct (classic (ts = length mem1_v + 1)); try nia. congr.
  - revert MSG. unfold Memory.get_msg. rewrite Nat.add_1_r. ss.
    rewrite nth_error_app2; try nia.
    rewrite Nat.sub_diag.
    destruct mem_post; ss. i. inv MSG.
    econs.
    + rewrite <- app_assoc. ss.
    + rewrite app_length. s. rewrite Nat.add_1_r. ss.
  - ss.
Qed.

Lemma sim_rmw
      p m_pf st_last lc_last
      n tid
      vloc vold vnew old_ts st1_pf lc1_pf mem_pf st2_pf lc2_pf
      lc1_v mem1_v
      (EXEC_PF: Machine.pf_exec p m_pf)
      (EU_LAST: IdMap.find tid m_pf.(Machine.tpool) = Some (st_last, lc_last))
      (EU_STEP: ExecUnit.state_step tid (ExecUnit.mk st1_pf lc1_pf mem_pf) (ExecUnit.mk st2_pf lc2_pf mem_pf))
      (RTC: rtc (ExecUnit.state_step tid) (ExecUnit.mk st2_pf lc2_pf mem_pf) (ExecUnit.mk st_last lc_last mem_pf))
      (LOCAL1: sim_local n lc1_pf lc1_v)
      (MEMORY1: sim_memory n mem_pf mem1_v)
      (WF1_PF: Local.wf tid mem_pf lc1_pf)
      (WF1_V: Local.wf tid mem1_v lc1_v)
      (STEP_PF: Local.rmw vloc vold vnew old_ts (n + 1) tid lc1_pf mem_pf lc2_pf):
  exists lc2_v mem2_v,
    (<<STEP_V: Local.vrmw vloc vold vnew old_ts (n + 1) tid lc1_v mem1_v lc2_v mem2_v>>) /\
    (<<LOCAL2: sim_local (n + 1) lc2_pf lc2_v>>) /\
    (<<MEMORY2: sim_memory (n + 1) mem_pf mem2_v>>) /\
    (<<PROMISES_PF: lc2_pf.(Local.promises) = Promises.unset (n + 1) lc1_pf.(Local.promises)>>).
Proof.
  hexploit ExecUnit.no_promise_rmw_spec; cycle 2.
  { instantiate (1 := (ExecUnit.mk st2_pf lc2_pf mem_pf)). s. instantiate (1 := (ExecUnit.mk st1_pf lc1_pf mem_pf)). eauto. }
  all: eauto; ss.
  { inv EXEC_PF. inv NOPROMISE. eapply PROMISES; eauto. }
  intro OLD_TS_LATEST. guardH OLD_TS_LATEST.

  destruct lc1_pf as [coh_pf vrn_pf vpr_pf vpa_pf vpc_pf promises_pf].
  destruct lc1_v as [coh_v vrn_v vpr_v vpa_v vpc_v promises_v].
  inv LOCAL1. dup MEMORY1. inv MEMORY0. inv STEP_PF. ss. subst.
  esplits.
  - econs; ss.
    + eapply Memory.latest_ts_latest. rewrite OLD_TS_LATEST.
      erewrite Memory.latest_ts_upper; eauto. nia.
    + eapply sim_memory_read; eauto. nia.
    + unfold Memory.append. rewrite Nat.add_1_r. refl.
  - econs; eauto; s. i.
    revert PROMISE0. rewrite Promises.unset_o. condtac; ss. i.
    exploit PROMISES_PF; eauto. i.
    destruct (classic (ts = length mem1_v + 1)); try nia. congr.
  - revert MSG. unfold Memory.get_msg. rewrite Nat.add_1_r. ss.
    rewrite nth_error_app2; try nia.
    rewrite Nat.sub_diag.
    destruct mem_post; ss. i. inv MSG.
    econs.
    + rewrite <- app_assoc. ss.
    + rewrite app_length. s. rewrite Nat.add_1_r. ss.
  - ss.
Qed.

Lemma sim_next_fulfill
      n tid
      mem_pf mem1_v
      st1 lc1_pf st2 lc2_pf st3 lc3_pf ord vloc vval res
      lc1_v
      (MEMORY1: sim_memory n mem_pf mem1_v)
      (LOCAL1: sim_local n lc1_pf lc1_v)
      (WF1_PF: Local.wf tid mem_pf lc1_pf)
      (WF1_V: Local.wf tid mem1_v lc1_v)
      (STEPS: rtc (ExecUnit.state_step tid)
                  (ExecUnit.mk st1 lc1_pf mem_pf)
                  (ExecUnit.mk st2 lc2_pf mem_pf))
      (STEP_ST: State.step (Event.write false ord vloc vval res) st2 st3)
      (STEP_LC: Local.fulfill vloc vval res (n + 1) tid lc2_pf mem_pf lc3_pf):
  exists lc2_v lc3_v mem3_v,
    (<<STEPS_V: rtc (ExecUnit.view_step tid)
                    (ExecUnit.mk st1 lc1_v mem1_v)
                    (ExecUnit.mk st2 lc2_v mem1_v)>>) /\
    (<<STEP_V: ExecUnit.view_step tid (ExecUnit.mk st2 lc2_v mem1_v) (ExecUnit.mk st3 lc3_v mem3_v)>>) /\
    (<<LOCAL3: sim_local (n + 1) lc3_pf lc3_v>>) /\
    (<<MEMORY3: sim_memory (n + 1) mem_pf mem3_v>>) /\
    (<<PROMISES2_PF: lc2_pf.(Local.promises) = lc1_pf.(Local.promises)>>) /\
    (<<PROMISES3_PF: lc3_pf.(Local.promises) = Promises.unset (n + 1) lc1_pf.(Local.promises)>>).
Proof.
  revert n mem1_v st3 lc3_pf ord vloc vval res lc1_v MEMORY1 LOCAL1 WF1_PF WF1_V STEP_ST STEP_LC.
  dependent induction STEPS; i.
  { exploit sim_fulfill; eauto. i. des.
    esplits; eauto.
    econs. econs; eauto. econs 3; eauto. }
  inv H. inv STEP.
  exploit sim_step; eauto. i. des.
  - destruct y. ss. subst.
    exploit Local.step_wf; try exact LOCAL; eauto. i.
    exploit Local.view_step_wf; try exact STEP_V; eauto. i.
    exploit IHSTEPS; eauto. i. des.
    esplits.
    + econs 2; eauto. econs. econs; eauto.
    + eauto.
    + ss.
    + ss.
    + congr.
    + congr.
  - exfalso.
    exploit ExecUnit.rtc_state_step_incr; try exact STEPS. i.
    inv STEP_LC. inv WRITABLE. inv COHMAX. inv x0. inv LC. ss.
    specialize (COH0 loc). specialize (MAX loc).
    inv MAX. unfold le in *.
    rewrite TS in COH0.
    exploit le_lt_trans; [exact COH0|exact EXT|]. i. nia.
Qed.

Lemma sim_next_rmw
      p m_pf st_last lc_last
      n tid
      mem_pf mem1_v
      st1 lc1_pf st2 lc2_pf st3 lc3_pf ordr ordw vloc vold vnew old_ts
      lc1_v
      (EXEC_PF: Machine.pf_exec p m_pf)
      (EU_LAST: IdMap.find tid m_pf.(Machine.tpool) = Some (st_last, lc_last))
      (EU_STEP: ExecUnit.state_step tid (ExecUnit.mk st2 lc2_pf mem_pf) (ExecUnit.mk st3 lc3_pf mem_pf))
      (RTC: rtc (ExecUnit.state_step tid) (ExecUnit.mk st3 lc3_pf mem_pf) (ExecUnit.mk st_last lc_last mem_pf))
      (MEMORY1: sim_memory n mem_pf mem1_v)
      (LOCAL1: sim_local n lc1_pf lc1_v)
      (WF1_PF: Local.wf tid mem_pf lc1_pf)
      (WF1_V: Local.wf tid mem1_v lc1_v)
      (STEPS: rtc (ExecUnit.state_step tid)
                  (ExecUnit.mk st1 lc1_pf mem_pf)
                  (ExecUnit.mk st2 lc2_pf mem_pf))
      (STEP_ST: State.step (Event.rmw ordr ordw vloc vold vnew) st2 st3)
      (STEP_LC: Local.rmw vloc vold vnew old_ts (n + 1) tid lc2_pf mem_pf lc3_pf):
  exists lc2_v lc3_v mem3_v,
    (<<STEPS_V: rtc (ExecUnit.view_step tid)
                    (ExecUnit.mk st1 lc1_v mem1_v)
                    (ExecUnit.mk st2 lc2_v mem1_v)>>) /\
    (<<STEP_V: ExecUnit.view_step tid (ExecUnit.mk st2 lc2_v mem1_v) (ExecUnit.mk st3 lc3_v mem3_v)>>) /\
    (<<LOCAL3: sim_local (n + 1) lc3_pf lc3_v>>) /\
    (<<MEMORY3: sim_memory (n + 1) mem_pf mem3_v>>) /\
    (<<PROMISES2_PF: lc2_pf.(Local.promises) = lc1_pf.(Local.promises)>>) /\
    (<<PROMISES3_PF: lc3_pf.(Local.promises) = Promises.unset (n + 1) lc1_pf.(Local.promises)>>).
Proof.
  revert n mem1_v st3 lc3_pf ordr ordw vloc vold vnew lc1_v EU_STEP RTC MEMORY1 LOCAL1 WF1_PF WF1_V STEP_ST STEP_LC.
  dependent induction STEPS; i.
  { exploit sim_rmw; try exact STEP_LC; eauto. i. des.
    esplits; eauto.
    econs. econs; eauto. econs 4; eauto. }
  inv H. inv STEP.
  exploit sim_step; eauto. i. des.
  - destruct y. ss. subst.
    exploit Local.step_wf; try exact LOCAL; eauto. i.
    exploit Local.view_step_wf; try exact STEP_V; eauto. i.
    exploit IHSTEPS; eauto. i. des.
    esplits.
    + econs 2; eauto. econs. econs; eauto.
    + eauto.
    + ss.
    + ss.
    + congr.
    + congr.
  - exfalso.
    exploit ExecUnit.rtc_state_step_incr; try exact STEPS. i.
    inv STEP_LC. inv WRITABLE. inv COHMAX. inv x0. inv LC. ss.
    specialize (COH1 loc). specialize (MAX loc).
    inv MAX. unfold le in *.
    rewrite TS in COH1.
    exploit le_lt_trans; [exact COH1|exact EXT|]. i. nia.
Qed.

Lemma sim_step_last
      e tid lc1_pf lc2_pf mem_pf
      lc1_v mem_v
      (LOCAL1: sim_local (length mem_pf) lc1_pf lc1_v)
      (MEMORY: sim_memory (length mem_pf) mem_pf mem_v)
      (WF1_PF: Local.wf tid mem_pf lc1_pf)
      (WF1_V: Local.wf tid mem_v lc1_v)
      (STEP_PF: Local.step e tid mem_pf lc1_pf lc2_pf):
  (<<STEP_V: Local.view_step e tid mem_v mem_v lc1_v lc2_pf>>) /\
  (<<LOCAL2: sim_local (length mem_pf) lc2_pf lc2_pf>>) /\
  (<<PROMISES: lc2_pf.(Local.promises) = bot>>).
Proof.
  exploit sim_local_last; eauto. i. subst.
  exploit sim_memory_last; eauto. i. subst.
  destruct lc1_v. dup LOCAL1. inv LOCAL0. ss. subst.
  inv STEP_PF.
  - (* internal *)
    esplits; eauto. econs 1; ss.
  - (* read *)
    esplits.
    + econs 2; eauto.
    + eapply sim_local_refl; eauto. inv STEP. ss.
    + inv STEP. ss.
  - (* fulfill *)
    inv STEP. ss. unfold Promises.lookup, bot, fun_bot in *. des_ifs.
  - (* rmw *)
    inv STEP. ss. unfold Promises.lookup, bot, fun_bot in *. des_ifs.
  - (* rmw failure *)
    esplits.
    + econs 5; eauto.
    + eapply sim_local_refl; eauto. inv STEP. ss.
    + inv STEP. ss.
  - (* mfence *)
    esplits.
    + econs 6; eauto.
    + eapply sim_local_refl; eauto. inv STEP. ss.
    + inv STEP. ss.
  - (* sfence *)
    esplits.
    + econs 7; eauto.
    + eapply sim_local_refl; eauto. inv STEP. ss.
    + inv STEP. ss.
  - (* flush *)
    esplits.
    + econs 8; eauto.
    + eapply sim_local_refl; eauto. inv STEP. ss.
    + inv STEP. ss.
  - (* flushopt *)
    esplits.
    + econs 9; eauto.
    + eapply sim_local_refl; eauto. inv STEP. ss.
    + inv STEP. ss.
Qed.

Lemma sim_rtc_step_last
      tid st1 lc1_pf st2 lc2_pf mem_pf
      lc1_v mem_v
      (LOCAL1: sim_local (length mem_pf) lc1_pf lc1_v)
      (MEMORY: sim_memory (length mem_pf) mem_pf mem_v)
      (WF1_PF: Local.wf tid mem_pf lc1_pf)
      (WF1_V: Local.wf tid mem_v lc1_v)
      (STEPS: rtc (ExecUnit.state_step tid)
                  (ExecUnit.mk st1 lc1_pf mem_pf)
                  (ExecUnit.mk st2 lc2_pf mem_pf)):
  (<<STEPS_V: rtc (ExecUnit.view_step tid)
                  (ExecUnit.mk st1 lc1_v mem_v)
                  (ExecUnit.mk st2 lc2_pf mem_v)>>) /\
  (<<LOCAL2: sim_local (length mem_pf) lc2_pf lc2_pf>>) /\
  (<<PROMISES: lc2_pf.(Local.promises) = bot>>).
Proof.
  exploit sim_local_last; eauto. i. subst.
  exploit sim_memory_last; eauto. i. subst.
  revert LOCAL1 MEMORY WF1_PF WF1_V.
  dependent induction STEPS; i.
  { splits; eauto. inv LOCAL1. ss. }
  inv H. inv STEP. ss.
  exploit sim_step_last; try exact LOCAL; eauto. i. des.
  destruct y. ss. subst.
  exploit Local.step_wf; try exact LOCAL; eauto. i.
  exploit (IHSTEPS state st2 lc2_pf local mem_v); eauto. i. des.
  splits; eauto. econs 2; eauto. econs. econs; eauto.
Qed.

Lemma sim_rtc_machine_step_last
      m1_pf m2_pf m1_v
      (SIM1: sim (length m1_pf.(Machine.mem)) m1_pf m1_v)
      (EXEC_PF: Machine.state_exec m1_pf m2_pf)
      (WF1_PF: Machine.wf m1_pf)
      (WF1_V: Machine.wf m1_v):
  exists m2_v,
    (<<STEPS_V: rtc (Machine.step ExecUnit.view_step) m1_v m2_v>>) /\
    (<<SIM2: sim (length m1_pf.(Machine.mem)) m2_pf m2_v>>).
Proof.
  inv EXEC_PF.
  assert (IN: forall tid sl1_pf
                (FIND1: IdMap.find tid m1_pf.(Machine.tpool) = Some sl1_pf),
             exists sl2_pf,
               IdMap.find tid m2_pf.(Machine.tpool) = Some sl2_pf /\
               rtc (ExecUnit.state_step tid)
                   (ExecUnit.mk (fst sl1_pf) (snd sl1_pf) m1_pf.(Machine.mem))
                   (ExecUnit.mk (fst sl2_pf) (snd sl2_pf) m1_pf.(Machine.mem))).
  { i. specialize (TPOOL tid). rewrite FIND1 in TPOOL. inv TPOOL. esplits; ss. }
  assert (OUT: forall tid
                 (FIND1: IdMap.find tid m1_pf.(Machine.tpool) = None),
             IdMap.find tid m1_pf.(Machine.tpool) = IdMap.find tid m2_pf.(Machine.tpool)).
  { i. specialize (TPOOL tid). rewrite FIND1 in TPOOL. inv TPOOL. ss. }
  assert (P: forall tid sl1_pf
               (FIND1: IdMap.find tid m1_pf.(Machine.tpool) = Some sl1_pf),
             IdMap.find tid m1_pf.(Machine.tpool) = Some sl1_pf).
  { ss. }
  clear TPOOL.
  setoid_rewrite IdMap.elements_spec in IN at 1.
  setoid_rewrite IdMap.elements_spec in OUT at 1.
  setoid_rewrite IdMap.elements_spec in P at 1.
  generalize (IdMap.elements_3w m1_pf.(Machine.tpool)). intro NODUP. revert NODUP.
  revert IN OUT P. generalize (IdMap.elements (m1_pf.(Machine.tpool))). intro ps.
  revert m1_pf m1_v SIM1 WF1_PF WF1_V MEM. induction ps; ss; i.
  { esplits; try refl.
    inv SIM1. econs.
    - i. specialize (TPOOL tid). rewrite <- OUT; ss.
    - rewrite <- MEM. ss.
  }

  destruct a as [tid [st1_pf lc1_pf]].
  exploit (P tid); eauto.
  { condtac; ss. revert X. condtac; ss. congr. }
  intro FIND_PF.
  exploit (IN tid); eauto.
  { condtac; ss. revert X. condtac; ss. congr. }
  i. des.
  dup SIM1. inv SIM0. specialize (TPOOL tid).
  rewrite FIND_PF in TPOOL. inv TPOOL.
  destruct b as [st1_v lc1_v]. inv REL. ss. subst.
  dup WF1_PF. inv WF1_PF0. exploit WF; eauto. i.
  dup WF1_V. inv WF1_V0. exploit WF0; eauto. i.
  clear WF WF0.
  exploit sim_rtc_step_last; try exact LOCAL; eauto; try apply x; try apply x2. i. des.
  exploit Machine.rtc_eu_step_step; try eapply x1; eauto. i.
  exploit Machine.rtc_eu_step_step; try eapply STEPS_V; eauto. i.
  inv NODUP.
  assert (TID: forall tid' sl
                 (FIND: SetoidList.findA (fun id': IdMap.key => if equiv_dec tid id' then true else false) ps = Some sl),
             tid' <> tid).
  { ii. subst. apply H2. revert FIND. clear. induction ps; ss.
    destruct a. destruct (equiv_dec tid k); ss.
    - inv e. i. inv FIND. left. ss.
    - i. right. apply IHps. ss.
  }
  inv SIM1.
  exploit (IHps (Machine.mk (IdMap.add tid (fst sl2_pf, snd sl2_pf) m1_pf.(Machine.tpool)) m1_pf.(Machine.mem))
                (Machine.mk (IdMap.add tid (fst sl2_pf, snd sl2_pf) m1_v.(Machine.tpool)) m1_v.(Machine.mem))); ss.
  - econs; ss. i.
    repeat rewrite IdMap.add_spec. condtac; ss; eauto.
  - eapply Machine.rtc_step_state_step_wf; eauto.
  - eapply Machine.rtc_step_view_step_wf; eauto.
  - i. eapply IN. condtac; ss. revert X. condtac; ss.
    rewrite e in *. exfalso. eapply TID; eauto.
  - i. rewrite IdMap.add_spec. condtac.
    + inversion e. subst. rewrite x0. destruct sl2_pf. ss.
    + eapply OUT. destruct (equiv_dec tid0 tid); ss.
  - i. rewrite IdMap.add_spec. condtac.
    + inversion e. subst. exfalso. eapply TID; eauto.
    + eapply P. destruct (equiv_dec tid0 tid); ss.
  - i. des. esplits; [|eauto]. etrans; eauto.
Qed.

Theorem promising_pf_to_view
        p m_pf smem
        (EXEC_PF: Machine.pf_exec p m_pf)
        (PMEM: Machine.persisted m_pf smem):
  exists m_v,
    <<EXEC_V: Machine.view_exec p m_v>> /\
    <<EQUIV: Machine.equiv m_pf m_v>> /\
    <<PMEM: Machine.persisted m_v smem>>.
Proof.
  cut (exists m2_pf m2_v,
          (<<EXEC_PF: Machine.state_exec m2_pf m_pf>>) /\
          (<<STEPS_V: rtc (Machine.step ExecUnit.view_step) (Machine.init p) m2_v>>) /\
          (<<SIM2: sim (length m_pf.(Machine.mem)) m2_pf m2_v>>) /\
          (<<WF2_PF: Machine.wf m2_pf>>) /\
          (<<WF2_V: Machine.wf m2_v>>)).
  { i. des.
    exploit sim_rtc_machine_step_last; try exact SIM2; eauto.
    { inv EXEC_PF0. rewrite MEM. ss. }
    i. des.
    assert (EQUIV: Machine.equiv m_pf m2_v0).
    { exploit Machine.state_exec_wf; eauto. i.
      eapply sim_last; eauto.
      inv EXEC_PF0. rewrite MEM in *. ss.
    }
    esplits; [econs; etrans; eauto | ss |].
    ii. specialize (PMEM loc). inv PMEM.
    inv EQUIV. econs.
    { rewrite <- MEM. eauto. }
    intros tid sl. i.
    specialize (LATEST tid sl). rewrite <- TPOOL in FIND. eapply LATEST in FIND.
    rewrite <- MEM. ss.
  }

  generalize EXEC_PF. intro EXEC_PF'.
  inv EXEC_PF. specialize (init_sim p). i. des.
  specialize (Machine.init_wf p). intro WF_V.
  exploit rtc_promise_step_sim; eauto. i. des.
  exploit Machine.rtc_step_promise_step_wf; eauto. intro WF_PF.
  remember (Machine.init p) as m1_v.
  clear Heqm1_v STEP1 SIM PROMISES_WF.

  remember (length m_pf.(Machine.mem) - 0) as n.
  replace 0 with (length m_pf.(Machine.mem) - n) in SIM2, PROMISES_WF2 by nia.
  clear Heqn.
  rename STEP2 into EXEC_PF, SIM2 into SIM, PROMISES_WF2 into PROMISES_WF.
  revert m1 m1_v EXEC_PF SIM PROMISES_WF WF_PF WF_V.
  induction n; i.
  { replace (length m_pf.(Machine.mem) - 0) with (length m_pf.(Machine.mem)) in * by nia.
    esplits; eauto. }

  destruct (classic (length (Machine.mem m_pf) > n)); cycle 1.
  { eapply IHn; eauto.
    - replace (length (Machine.mem m_pf) - n) with 0 in * by nia.
      replace (length (Machine.mem m_pf) - S n) with 0 in * by nia.
      ss.
    - replace (length (Machine.mem m_pf) - n) with 0 in * by nia.
      replace (length (Machine.mem m_pf) - S n) with 0 in * by nia.
      ss.
  }

  exploit next_fulfill_exists; try exact EXEC_PF; eauto.
  { inv EXEC_PF. rewrite MEM. nia. }
  i. des.
  dup SIM. inv SIM0.
  specialize (TPOOL tid). rewrite FIND in *. inv TPOOL. inv REL.
  symmetry in H2. destruct b as [st1_v lc1_v]. ss. subst.
  dup WF_PF. inv WF_PF0. exploit WF; eauto. i.
  dup WF_V. inv WF_V0. exploit WF0; eauto. i.
  clear WF WF0. unguard. des.
  - exploit sim_next_fulfill; try exact LOCAL; eauto; try apply x; try apply x1. i. des.
    exploit Machine.rtc_eu_step_step; [exact FIND|refl|..]; i.
    { etrans; [eauto|]. econs 2; [|refl].
      econs. econs; [eauto|econs 3; eauto|]; ss. }
    exploit Machine.rtc_eu_step_step; [eapply H2|refl|..]; i.
    { etrans; [eauto|]. econs 2; eauto. }
    exploit Machine.rtc_step_state_step_wf; try exact x2; eauto. i.
    exploit Machine.rtc_step_view_step_wf; try exact x3; eauto. i.
    exploit (IHn (Machine.mk (IdMap.add tid (st3, lc3) m1.(Machine.tpool)) m1.(Machine.mem))
                 (Machine.mk (IdMap.add tid (st3, lc3_v) m1_v.(Machine.tpool)) mem3_v)); eauto.
    { inv EXEC2. econs; ss. }
    { replace (length (Machine.mem m_pf) - S n + 1) with (length (Machine.mem m_pf) - n) in * by nia.
      econs; ss; i.
      repeat rewrite IdMap.add_spec. condtac; ss.
      { inversion e. subst. econs. econs; ss. }
      inv SIM. specialize (TPOOL tid0). inv TPOOL; ss.
      destruct a as [st_pf lc_pf], b as [st_v lc_v].
      inv REL. ss. subst. econs. econs; ss.
      inv LOCAL0. econs; ss. i.
      exploit PROMISES_PF; eauto. i.
      destruct (classic (ts = length m_pf.(Machine.mem) - n)); try by nia. subst.
      exfalso.
      inv STEP_LC. inv PROMISES_WF. rewrite PROMISES2_PF in *.
      exploit SOUND; try exact FIND; eauto. i. des.
      symmetry in H1.
      exploit SOUND; try eapply H1; eauto. i. des.
      congr.
    }
    { inv PROMISES_WF. econs; s; i; unnw.
      - revert FIND0. rewrite IdMap.add_spec. condtac; ss; eauto.
        ii. inv FIND0. inversion e. subst.
        revert LOOKUP. rewrite PROMISES3_PF.
        rewrite Promises.unset_o. condtac; ss. i.
        exploit SOUND; eauto.
      - exploit COMPLETE; try exact GET; try by nia. i. des.
        rewrite IdMap.add_spec. condtac; ss; eauto.
        inversion e. subst. esplits; eauto.
        rewrite PROMISES3_PF. rewrite Promises.unset_o. condtac; ss; try congr.
        inversion e0. subst. nia.
    }
    i. des.
    esplits; try exact SIM2; eauto. etrans; eauto.
  - inv EXEC_PF. specialize (TPOOL tid). inv TPOOL; try congr. destruct b as (st_last, lc_last). symmetry in H3.
    clear REL H1 a MEM.
    exploit sim_next_rmw; try exact EXEC_PF'; try exact H3; try exact LOCAL; try exact STEP_LC; eauto; try apply x; try apply x1.
    { econs. econs; eauto. econs 4; eauto. }
    { inv EXEC2. specialize (TPOOL tid). inv TPOOL; try congr; ss.
      rewrite IdMap.add_spec in *. des_ifs; try congr.
      rewrite H3 in H4. inv H4. ss.
    }
    clear H3 st_last lc_last.
    i. des.
    exploit Machine.rtc_eu_step_step; [exact FIND|refl|..]; i.
    { etrans; [eauto|]. econs 2; [|refl].
      econs. econs; [eauto|econs 4; eauto|]; ss. }
    exploit Machine.rtc_eu_step_step; [eapply H2|refl|..]; i.
    { etrans; [eauto|]. econs 2; eauto. }
    exploit Machine.rtc_step_state_step_wf; try exact x2; eauto. i.
    exploit Machine.rtc_step_view_step_wf; try exact x3; eauto. i.
    exploit (IHn (Machine.mk (IdMap.add tid (st3, lc3) m1.(Machine.tpool)) m1.(Machine.mem))
                 (Machine.mk (IdMap.add tid (st3, lc3_v) m1_v.(Machine.tpool)) mem3_v)); eauto.
    { replace (length (Machine.mem m_pf) - S n + 1) with (length (Machine.mem m_pf) - n) in * by nia.
      econs; ss; i.
      repeat rewrite IdMap.add_spec. condtac; ss.
      { inversion e. subst. econs. econs; ss. }
      inv SIM. specialize (TPOOL tid0). inv TPOOL; ss.
      destruct a as [st_pf lc_pf], b as [st_v lc_v].
      inv REL. ss. subst. econs. econs; ss.
      inv LOCAL0. econs; ss. i.
      exploit PROMISES_PF; eauto. i.
      destruct (classic (ts = length m_pf.(Machine.mem) - n)); try by nia. subst.
      exfalso.
      inv STEP_LC. inv PROMISES_WF. rewrite PROMISES2_PF in *.
      exploit SOUND; try exact FIND; eauto. i. des.
      symmetry in H1.
      exploit SOUND; try eapply H1; eauto. i. des.
      congr.
    }
    { inv PROMISES_WF. econs; s; i; unnw.
      - revert FIND0. rewrite IdMap.add_spec. condtac; ss; eauto.
        ii. inv FIND0. inversion e. subst.
        revert LOOKUP. rewrite PROMISES3_PF.
        rewrite Promises.unset_o. condtac; ss. i.
        exploit SOUND; eauto.
      - exploit COMPLETE; try exact GET; try by nia. i. des.
        rewrite IdMap.add_spec. condtac; ss; eauto.
        inversion e. subst. esplits; eauto.
        rewrite PROMISES3_PF. rewrite Promises.unset_o. condtac; ss; try congr.
        inversion e0. subst. nia.
    }
    i. des.
    esplits; try exact SIM2; eauto. etrans; eauto.
Qed.

Theorem promising_to_view
        p m_p smem
        (EXEC: Machine.exec p m_p)
        (PMEM: Machine.persisted m_p smem):
  exists m_v,
    <<EXEC_V: Machine.view_exec p m_v>> /\
    <<EQUIV: Machine.equiv m_p m_v>> /\
    <<PMEM: Machine.persisted m_v smem>>.
Proof.
  apply promising_to_promising_pf in EXEC.
  apply promising_pf_to_view; auto.
Qed.


Require Import AutoSep Malloc Arrays8.

Definition mainS := SPEC reserving 12
  PREonly[_] mallocHeap 0.

Definition writeS := SPEC("fd", "buf", "len") reserving 4
  Al len,
  PRE[V] V "buf" =?>8 len * [| (wordToNat (V "len") <= len)%nat |]
  POST[_] V "buf" =?>8 len.

Opaque allocated.

Definition m := bimport [[ "sys"!"abort" @ [abortS], "sys"!"printInt" @ [printIntS],
                           "sys"!"listen" @ [listenS], "sys"!"accept" @ [acceptS],
                           "sys"!"read" @ [readS], "sys"!"write" @ [Sys.writeS],
                           "malloc"!"malloc" @ [mallocS] ]]
  bmodule "test" {{
    bfunction "write"("fd", "buf", "len") [writeS]
      Assert [Al len,
        PRE[V] buffer_splitAt (wordToNat (V "len")) (V "buf") len
          * [| (wordToNat (V "len") <= len)%nat |]
        POST[_] buffer_joinAt (wordToNat (V "len")) (V "buf") len];;

      Call "sys"!"write"("fd", "buf", "len")
      [PRE[_] Emp POST[_] Emp];;
      Return 0
    end with bfunctionNoRet "main"("fdl", "fd", "buf", "n") [mainS]
      "fdl" <-- Call "sys"!"listen"(8080%N)
      [PREonly[_] mallocHeap 0];;

      "fd" <-- Call "sys"!"accept"("fdl")
      [PREonly[_] mallocHeap 0];;

      "buf" <-- Call "malloc"!"malloc"(0, 10)
      [PREonly[_, R] R =?> 10];;

      Note [please_materialize_buffer 10];;

      "n" <-- Call "sys"!"read"("fd", "buf", 40)
      [PREonly[V] V "buf" =?>8 40];;

      [PREonly[V] V "buf" =?>8 40]
      While ("n" <> 0) {
        If ("n" <= 40) {
          Call "test"!"write"("fd", "buf", "n")
          [PREonly[V] V "buf" =?>8 40]
        } else {
          Skip
        };;

        "n" <-- Call "sys"!"read"("fd", "buf", 40)
        [PREonly[V] V "buf" =?>8 40]
      };;

      Call "sys"!"abort"()
      [PREonly[_] [| False |] ]
    end
  }}.

Definition hints : TacPackage.
  prepare (materialize_buffer, buffer_split_tagged) buffer_join_tagged.
Defined.

Hint Extern 1 (@eq W _ _) => words.

Lemma le_40 : forall w : W,
  w <= natToW 40
  -> (wordToNat w <= 40)%nat.
  intros; pre_nomega.
  rewrite wordToNat_natToWord_idempotent in * by reflexivity; omega.
Qed.

Hint Immediate le_40.

Ltac t :=
  try match goal with
        | [ |- context[evalCond _ Le (RvImm (natToW 40)) _ _] ] =>
          post; evaluate hints; exists 40
      end;
  sep hints; auto.

Theorem ok : moduleOk m.
  vcgen; abstract t.
Qed.