(** * Invertibility results for the negative phase

This file proves that exchange is admissible also in the list L in
[seq Gamma Delta (> L)]. For that, some invertibility lemmas are
needed.
 *)
Require Export LL.Misc.Hybrid.
Require Export LL.SL.MMLL.Tactics.
Require Import Lia.
Require Import LL.Misc.Permutations.
Require Import FunInd.
Require Import Coq.Program.Equality.
Require Export LL.Misc.UtilsForall.

Export ListNotations.
Export LLNotations.
Set Implicit Arguments.

Section InvNPhase .
    Context `{SI : SigMMLL}.
  Context `{OLS: OLSig}.
  Hint Constructors isFormula  seqN IsPositiveAtom : 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).

  Theorem exp_weight0LF : forall l L, 0%nat = complexity l + complexityL L -> False.
  Proof.
    intros.
    assert(complexity l > 0%nat) by (apply Complexity0).
    lia.
  Qed.

  Theorem EquivAuxBot :  forall CC LC M M',
      |-- CC ; LC ; (UP (M ++ M') ) ->
     |-- CC ;  LC ; (UP (M ++ Bot :: M') ) .
  Proof with sauto.
    intros.
    remember (complexityL M) as SizeM.
    revert dependent CC.
    revert dependent LC.
    revert dependent M.
    revert dependent M'.
    induction SizeM using strongind;intros ...

    symmetry in HeqSizeM; apply ComplexityL0 in HeqSizeM ...
    solveLL ...

    destruct M as [ | a]; simpl in HeqSizeM.
    inversion HeqSizeM.
    destruct a; simpl in *; invTri' H0;solveLL;
      repeat rewrite app_comm_cons.
    all:  try match goal with
          |  [ |- seq _ _ _ (UP (?M ++ Bot :: _)) ] =>
             eapply H with (m:= complexityL M);simpl in *; inversion HeqSizeM; solveF
          end.
    assert (Hvar : proper (VAR con 0%nat)) by constructor.
    generalize (ComplexityUniformEq H5 properX Hvar);intro.
    lia.
  Qed.

  Theorem EquivAuxWith :  forall F G CC LC M M',
      |-- CC ; LC ; (UP (M ++ [F] ++ M') ) ->
      |-- CC ; LC ;(UP (M ++ [G] ++ M') ) ->
      |-- CC ; LC ; (UP (M ++ (AAnd F G) :: M') ) .
  Proof with sauto.
    intros.
    remember (complexityL M) as SizeM.
    revert dependent CC.
    revert dependent LC.
    revert dependent M.
    revert dependent M'.
    induction SizeM using strongind;intros ...

    symmetry in HeqSizeM; apply ComplexityL0 in HeqSizeM ...

    destruct M as [ | a]; simpl in HeqSizeM.
    inversion HeqSizeM.

    destruct a; simpl in *; invTri' H0;solveLL;
      repeat rewrite app_comm_cons.
   all:   try solve [
            match goal with
            |  [ |- seq _ _ _ (UP (?M ++ (AAnd _ _) :: _)) ] =>
               eapply H with (m:= complexityL M);simpl in *; inversion HeqSizeM;solveF;FLLInversionAll;auto
            end] .
    eapply H with (M:= o x:: M) (m:= complexityL (o x:: M));simpl in *; inversion HeqSizeM;solveF;FLLInversionAll;auto.
    generalize (ComplexityUniformEq H6 properX (proper_VAR con 0%nat));intro...
  Qed.

  Theorem EquivAuxPar : forall F G CC LC M M',
      |-- CC ; LC ; (UP (M ++ [F ; G] ++ M') ) ->
      |-- CC ; LC ;(UP (M ++ (MOr F G) :: M') ) .
  Proof with sauto.
    intros.
    remember (complexityL M) as SizeM.
    revert dependent CC.
    revert dependent LC.
    revert dependent M.
    revert dependent M'.
    induction SizeM using strongind;intros ...

    symmetry in HeqSizeM; apply ComplexityL0 in HeqSizeM ...

    destruct M as [ | a]; simpl in HeqSizeM.
    inversion HeqSizeM.

    destruct a; simpl in *; invTri' H0;solveLL;
      repeat rewrite app_comm_cons;
      match goal with
      |  [ |- seq _ _ _ (UP (?M ++ (MOr F G) :: _)) ] =>
         eapply H with (m:= complexityL M);simpl in *; inversion HeqSizeM; solveF
      end.
    generalize (ComplexityUniformEq H5 properX (proper_VAR con 0%nat));intro...
  Qed.

  Theorem EquivAuxStore :
    forall F CC LC M M', positiveLFormula  F ->
                         |-- CC ; (LC ++ [F]) ;(UP (M ++ M') ) ->
                         |-- CC ; LC ; (UP (M ++ F :: M') ) .
  Proof with sauto.

    intros.
    remember (complexityL M) as SizeM.
    revert dependent CC;
    revert dependent LC;
    revert dependent M;
    revert dependent M'.
    induction SizeM using strongind;intros ...
    - symmetry in HeqSizeM; apply ComplexityL0 in HeqSizeM ...
      LLStore.
      LLExact H0.
    - destruct M as [ | a]; simpl in HeqSizeM.
      inversion HeqSizeM.
      destruct a;CleanContext;invTri' H1;try rewrite <- app_comm_cons;solveLL.
      -- eapply H0 with (m:= complexityL M)...
         inversion HeqSizeM;auto.
      -- eapply H0 with (m:= complexityL M)...
         inversion HeqSizeM;auto.
      -- eapply H0 with (m:= complexityL M)...
         inversion HeqSizeM;auto.
      -- eapply H0 with (m:= complexityL M)...
         inversion HeqSizeM;auto.
      -- eapply H0 with (m:= complexityL M)...
         inversion HeqSizeM;auto.
      -- rewrite app_comm_cons.
         eapply H0 with (m:= complexityL (a1 :: M))...
         inversion HeqSizeM;simpl;try lia.
      -- rewrite app_comm_cons.
         eapply H0 with (m:= complexityL (a2 :: M))...
         inversion HeqSizeM;simpl;try lia.
      -- eapply H0 with (m:= complexityL M)...
         inversion HeqSizeM;try lia.
      -- eapply H0 with (m:= complexityL M)...
         inversion HeqSizeM;try lia.
      -- rewrite app_comm_cons.
         rewrite app_comm_cons.
         eapply H0 with (m:= complexityL (a1 :: a2 :: M))...
         inversion HeqSizeM;simpl;try lia.
      -- eapply H0 with (m:= complexityL M)...
         inversion HeqSizeM;try lia.
      -- eapply H0 with (m:= complexityL M)...
         inversion HeqSizeM;try lia.
      -- rewrite app_comm_cons.
         eapply H0 with (m:= complexityL (o x :: M))...
         inversion HeqSizeM;simpl;try lia.
         generalize (ComplexityUniformEq H6 properX (proper_VAR con 0%nat));intro...  rewrite <- app_comm_cons...
      -- eapply H0 with (m:= complexityL M)...
         inversion HeqSizeM;try lia.
  Qed.

  Theorem EquivAuxQuest : forall a F CC LC M M',
      |--  (a,F)::CC ; LC ;(UP (M ++  M') ) ->
      |-- CC ; LC ; (UP (M ++ [Quest a F] ++ M') ) .
  Proof with sauto.
    intros.
    remember (complexityL M) as SizeM.
    revert dependent CC.
    revert dependent LC.
    revert dependent M.
    revert dependent M'.
    induction SizeM using strongind;intros ...

    symmetry in HeqSizeM; apply ComplexityL0 in HeqSizeM ...
    simpl;solveLL...

    destruct M; simpl in HeqSizeM.
    inversion HeqSizeM.

    destruct o; simpl in *; invTri' H0;solveLL;
      repeat rewrite app_comm_cons;
      try solve [
            match goal with
            |  [ |- seq _ _ _ (UP (?M ++ (Quest _ _) :: _)) ] =>
              eapply H with (m:= complexityL M);simpl in *; inversion HeqSizeM;solveF;FLLInversionAll;auto
            end] .

       rewrite perm_swap in H4.
      eapply H with (m:= complexityL M);simpl in *; inversion HeqSizeM;solveF;FLLInversionAll;auto.

    eapply H with (m:= complexityL (o x :: M));simpl in *; inversion HeqSizeM;solveF;FLLInversionAll;auto.
    generalize (ComplexityUniformEq H5 properX (proper_VAR con 0%nat));intro...
  Qed.

  Theorem EquivAuxTop :  forall CC LC M M',
      isFormulaL M ->
      |-- CC ; LC ; (UP (M ++ Top :: M') ) .
  Proof with sauto.
    intros.
    remember (complexityL M) as SizeM.
    revert dependent CC.
    revert dependent LC.
    revert dependent M.
    revert dependent M'.
    induction SizeM using strongind;intros ...

    symmetry in HeqSizeM; apply ComplexityL0 in HeqSizeM ...

    destruct M as [ | a]; simpl in HeqSizeM.

    inversion HeqSizeM.

    destruct a; simpl in *;solveLL;
      repeat rewrite app_comm_cons;
      try solve [
            match goal with
            |  [ |- seq _ _ _ (UP (?M ++ Top :: _)) ] =>
               eapply H with (m:= complexityL M);simpl in *; inversion HeqSizeM; solveF; inversion H0;subst;auto
            end].

    eapply H with (m:= complexityL (a1 ::M));simpl in * ; inversion HeqSizeM; solveF; inversion H0;subst;auto.
    inversion H3;subst...
    eapply H with (m:= complexityL (a2 ::M));simpl in * ; inversion HeqSizeM; solveF; inversion H0;subst;auto.
    inversion H3;subst...
    eapply H with (m:= complexityL (a1 :: a2 ::M));simpl in * ; inversion HeqSizeM; solveF; inversion H0;subst;auto.
    inversion H3;subst...

    rewrite <- app_comm_cons.

    LLStore.
    eapply H with (m:= complexityL M);simpl in *; inversion HeqSizeM; solveF; inversion H0;subst;auto.

     inversion H0... inversion H3...
   rewrite <- app_comm_cons.
    LLForall.
    eapply H with (M:= o x :: M) (m:= complexityL (o x ::M));simpl in * ; inversion HeqSizeM; solveF; inversion H0;subst;auto.

    rewrite (ComplexityUniformEq  H2 H1 (proper_VAR con 0%nat));auto.
  Qed.

  Theorem EquivAuxForAll : forall FX CC LC M M' ,
      isFormulaL M -> uniform_oo FX ->
      (forall t, proper t ->  |-- CC ; LC ; (UP (M ++ (FX t) ::M') )) ->
      |--  CC ; LC ; (UP (M ++ All FX:: M') ) .
  Proof with sauto.
    intros.
    remember (complexityL M) as SizeM.
    revert dependent CC.
    revert dependent LC.
    revert dependent M.
    revert dependent M'.
    induction SizeM using strongind;intros ...

    symmetry in HeqSizeM; apply ComplexityL0 in HeqSizeM ...

    destruct M as [ | a]; simpl in HeqSizeM.
    inversion HeqSizeM.
    inversion H1...

    destruct a; simpl in *;solveLL;
      try solve [eapply H with (m:= complexityL M);inversion HeqSizeM;subst;solveF;intros;solveLL; inversion H1;subst;auto;
                 generalize (H2 _ H3);intros Hs;invTri' Hs ;solveF]...

    eapply H with (M:= a1 :: M)(m:= complexityL (a1 :: M));inversion HeqSizeM;subst...  simpl. lia.
    inversion H5... intros. generalize (H2 _ H3);intros Hs;invTri' Hs ;solveF.

    eapply H with (M:= a2 :: M)(m:= complexityL (a2 :: M));inversion HeqSizeM;subst... simpl. lia.
    inversion H5... intros. generalize (H2 _ H3);intros Hs;invTri' Hs ;solveF.

    eapply H with (M:= a1 :: a2 :: M)(m:= complexityL (a1 :: a2 :: M));inversion HeqSizeM;subst... simpl. lia.
    inversion H5... intros. generalize (H2 _ H3);intros Hs;invTri' Hs ;solveF.

   inversion H5...
   LLStore.
    eapply H with (M:= M)(m:= complexityL (M));inversion HeqSizeM;subst... intros. generalize (H2 _ H3);intros Hs;invTri' Hs ;solveF.
    inversion H5...

   LLForall.

    eapply H with (M:=  o x :: M)(m:= complexityL (o x :: M));inversion HeqSizeM;subst...
    generalize (ComplexityUniformEq H4 H3 (proper_VAR con 0%nat));intros... simpl...
    intros...

    generalize (H2 _ H8);intros Hs. invTri' Hs...
    apply H14 in H3...
  Qed.

  Theorem EquivUpArrow : forall B L L' M n,
      isFormulaL L' ->
      (n |--- B ; M ; UP L) ->
      Permutation L L' ->
      |-- B ; M ;  UP L'.
  Proof with sauto.
    intros.
    remember (complexityL L) as w.
    generalize dependent n .
    generalize dependent L .
    generalize dependent L' .
    generalize dependent B .
    generalize dependent M .
    generalize dependent w .

    induction w as [| w' IH] using strongind;  intros ;  destruct L as [|l]...
    +  apply seqNtoSeq in H0;auto.
    + inversion Heqw.
      apply exp_weight0LF in H3...
    +  destruct L' as [| l']...

       assert
         ((l = l' /\ Permutation L L') \/
          (exists L1 L2 L1' L2', L = L1 ++ [l'] ++ L2 /\ L' = L1' ++ [l] ++ L2' /\ Permutation (L1 ++ L2) (L1' ++ L2') )) .
       { checkPermutationCases H1.
         right.
         assert (exists T1 T2, L' = T1 ++ [l] ++ T2).
         { induction x.
           do 2 eexists []...
           sauto.
           assert (In l  L') as Hm.
           rewrite H1...
           apply in_split;auto. }
         assert (exists T1 T2, L = T1 ++ [l'] ++ T2).
         { induction x.
           do 2 eexists []...
           sauto.
           assert (In l'  L) as Hm.
           rewrite H3...
           apply in_split;auto. }
          simplifier.
       eexists x0; eexists x1;eexists x2; eexists x3.
       intuition.
      rewrite H4 in H3.
      simpl in H3.
      rewrite Permutation_midle in H3.
      apply Permutation_cons_inv in H3.
      rewrite H2 in H1.
      simpl in H1.
      rewrite Permutation_midle in H1.
      apply Permutation_cons_inv in H1.
      rewrite H1. rewrite H3. auto. }
      destruct H2 as [Heq | Heq].
        ++ destruct Heq;subst.
           inversion H0;subst;try(simpl in Heqw; inversion Heqw; subst;simpl;try(lia)).
           +++  (* top *)
             LLTop.
           +++ (* bottom *)
             eapply IH with (L' :=L') in H7;auto.
             inversion H;subst;auto.
           +++ (* par *)
             eapply IH with (L' := F::G::L') in H7;auto.
             inversion H;subst.
             inversion H5;subst.
             SLSolve.
             simpl. lia.
           +++ (* with *)
             eapply IH with (m:= complexityL (F::L)) (L:= F ::L) (L' := F :: L') in H8;auto.
             eapply IH with (m:= complexityL (G::L)) (L := G :: L) (L' := G :: L') in H9;auto.
             simpl. lia.
             inversion H;subst.
             inversion H5;subst.
             SLSolve.
             simpl. lia.
             inversion H;subst.
             inversion H5;subst.
             change (F :: L') with ([F] ++ L').
             apply Forall_app;auto.
           +++  (* quest *)
             eapply IH with (m:= complexityL L) (L' :=L') in H7;auto.
             lia.
             inversion H;subst;auto.
           +++  (* store *)
             eapply IH with (m:= complexityL L) (L' :=L') in H9;auto.
             assert (complexity l' > 0) by (apply Complexity0).
             lia.
             inversion H;subst;auto.
           +++ (* forall *)
             eapply tri_fx';auto;intros.
             generalize (H9 x H2);intro.
             eapply IH with (m:= complexity (FX x) + complexityL L) (L' := FX x :: L') in H4;auto.
             assert(complexity (FX (VAR con 0%nat)) = complexity (FX x) ).
             apply ComplexityUniformEq;auto.
             constructor.
             lia.
             inversion H;subst.
             inversion H7;subst.
             change (FX x  :: L') with ([FX x ] ++ L').
             apply Forall_app;auto.

        ++
          destruct Heq as [L1 [L2 [L1' [L2' Heq]]]].
          destruct Heq as [Heq [Heq1 Heq2]];subst.

          inversion H0;subst.

          +++ (* top *)
            eapply EquivAuxTop with (M:= l' :: L1').
          rewrite app_comm_cons in H.
            autounfold in H.
            autounfold.
solveForall.
          +++ (* bottom *)
            eapply IH with (m:= complexityL (L1 ++ l' :: L2))(L:=L1 ++ l' :: L2) (L' := [l'] ++ L1' ++ L2') in H6 .
            simpl in H6.
            apply EquivAuxBot with (M:= l' :: L1');auto.
            simpl in Heqw. inversion Heqw. auto.
            inversion H;subst;auto.
              rewrite app_comm_cons in H.  SLFormulaSolve.
             autounfold in H.
            autounfold.
            solveForall.

            rewrite Permutation_midle.
            apply Permutation_cons;auto.
            auto.

          +++ (* par *)
            eapply IH with (m:= complexityL (F :: G :: L1 ++ l' :: L2))
                           (L:=F :: G :: L1 ++ l' :: L2)
                           (L' := [l'] ++ L1' ++ [F ; G] ++ L2') in H6.
            apply seqtoSeqN in H6. destruct H6.
            eapply EquivAuxPar with (M:= l' :: L1');simpl;simpl in H2;eauto using seqNtoSeq.
            simpl in Heqw. inversion Heqw. simpl.  lia.
              inversion H;subst;auto.
              rewrite app_comm_cons in H.  SLFormulaSolve.
   autounfold in H.
            autounfold.
            solveForall.

            apply Forall_app in H5;auto.
            inversion H5;subst;auto.
            inversion H3;subst;auto.
            inversion H9...
             apply Forall_app in H5;auto.
            inversion H5;subst;auto.
            inversion H3;subst;auto.
            inversion H9...
            rewrite Permutation_midle.
            rewrite Heq2. perm.
            auto.

          +++ (* with *)
            eapply IH with (m:= complexityL (F :: L1 ++ l' :: L2))
                           (L:=F :: L1 ++ l' :: L2)
                           (L' := [l'] ++ L1' ++ [F ] ++ L2') in H7;auto .
            eapply IH with (m:= complexityL (G :: L1 ++ l' :: L2))
                           (L:=G :: L1 ++ l' :: L2)
                           (L' := [l'] ++ L1' ++ [G ] ++ L2') in H8;auto .

            apply EquivAuxWith with (M := l' :: L1'); simpl;auto.
            inversion Heqw. simpl. lia.
              inversion H;subst;auto.
              rewrite app_comm_cons in H.  SLFormulaSolve.
              autounfold in H.
            autounfold.
            solveForall.

            apply Forall_app in H5;auto.
            inversion H5;subst;auto.
            inversion H3;subst;auto.
            inversion H10...

            rewrite Permutation_midle. rewrite Heq2. perm.
            inversion Heqw. simpl. lia.
              inversion H;subst;auto.
              rewrite app_comm_cons in H.  SLFormulaSolve.
              autounfold in H.
            autounfold.
            solveForall.

            apply Forall_app in H5;auto.
            inversion H5;subst;auto.
            inversion H3;subst;auto.
            inversion H10...
            simpl.

            rewrite Permutation_midle. rewrite Heq2. perm.

          +++ (* quest *)
            eapply IH with (m:= complexityL (L1 ++ l' :: L2))(L:=L1 ++ l' :: L2) (L' := [l'] ++ L1' ++ L2') in H6;auto .
            apply seqtoSeqN in H6. destruct H6.
            eapply EquivAuxQuest with (M := l' :: L1');simpl in H2.
            eauto using seqNtoSeq.

            inversion Heqw. simpl. lia.
              inversion H;subst;auto.
              rewrite app_comm_cons in H.  SLFormulaSolve.
              autounfold in H.
            autounfold.
            solveForall.

            rewrite Permutation_midle. rewrite Heq2. perm.

          +++ (* copy *)
            eapply IH with (m:= complexityL(L1 ++ l' :: L2))(L:=L1 ++ l' :: L2) (L' := [l'] ++ L1' ++ L2') in H8;auto .

            eapply EquivAuxStore with (M:=l' :: L1');eauto.
            rewrite Permutation_app_comm;eauto.
            inversion Heqw.
            assert (complexity l > 0) by (apply Complexity0).
            lia.
              inversion H;subst;auto.
              rewrite app_comm_cons in H.  SLFormulaSolve.
    autounfold in H.
            autounfold.
            solveForall.

            rewrite Permutation_midle. rewrite Heq2. perm.
          +++ (* forall *)

            assert(forall x, proper x -> |-- B; M; UP ((l' :: L1' ) ++ [FX x] ++ L2')).
            intros x pX.
            eapply IH with (m:= complexityL(FX x :: L1 ++ l' :: L2)) (L:=FX x :: L1 ++ l' :: L2)  ;auto.
            inversion Heqw.
            simpl.
            assert(complexity (FX (VAR con 0%nat)) = complexity (FX x) ).

            apply ComplexityUniformEq;auto.
            constructor. lia.

            inversion H;subst;auto.
            change ((l' :: L1') ++ [FX x] ++ L2') with ([l'] ++ L1' ++ [FX x] ++ L2').
              inversion H;subst;auto.
              rewrite app_comm_cons in H.  SLFormulaSolve.
    autounfold in H.
            autounfold.
            solveForall.

            apply Forall_app in H5;auto.
            inversion H5;subst;auto.
            inversion H3;subst;auto.
            inversion H12...
            rewrite Permutation_midle. rewrite Heq2. perm.

            assert(forall B  L L' M   FX,
                      isFormulaL L -> uniform_oo FX ->  (forall x, proper x -> |-- B ; M ; UP (L ++ [FX x]++ L')) ->  |-- B ; M ;  UP (L ++ [All FX] ++ L')).
            intros.
            eapply EquivAuxForAll;auto.

            apply H3 in H2;auto.
            inversion H;subst.
              inversion H;subst;auto.
              rewrite app_comm_cons in H.  SLFormulaSolve.
              autounfold in H.
            autounfold.
            solveForall.

  Qed.

  Theorem EquivUpArrow2 : forall B L L' M ,
      isFormulaL L' ->
      (|-- B ; M ; UP L) -> Permutation L L' ->
      |-- B ; M ;  UP L'.
    intros.
    apply seqtoSeqN in H0.
    destruct H0.
    eapply EquivUpArrow in H0;eauto.
  Qed.

  Generalizable All Variables.
  Global Instance Forall_morph :
    Proper ((@Permutation oo) ==> Basics.impl) (Forall positiveLFormula).
  Proof.
    unfold Proper; unfold respectful; unfold Basics.impl.
    intros.
    rewrite <- H;eauto.
  Qed.

  Lemma UpExtension: forall B M L F n,
      positiveLFormula F ->
      (n |--- B; F::M ; UP L) ->
      exists m, m<= S n /\ m |--- B; M ; UP (L ++ [F]).
  Proof with subst;auto.
    intros.
    remember (complexityL L) as w.
    generalize dependent L .
    generalize dependent B .
    generalize dependent F .
    generalize dependent M .
    generalize dependent n .
    generalize dependent w .

    induction w as [| w' IH] using strongind .
    intros n M F HNA B L HD Hw.
    + (* w = 0 *)
      destruct L. (* L must be empty. The second case is trivial *)
      { exists ((S n)). firstorder.
      simpl.
      eapply tri_store;auto. }
      simpl in Hw.
      apply exp_weight0LF in Hw;contradiction.
    + intros.
      destruct L. (* L cannot be empty *)
      inversion Heqw.
      inversion H0;auto;subst;inversion Heqw;subst.
      ++ (* top *)
        exists 0%nat.
        firstorder;[lia | eapply tri_top ].
      ++ (* bot *)
        apply IH with (m:= complexityL L) in H5;auto.
        destruct H5 as [n'  [IHn IHd]].
        exists (S n').
        firstorder;[lia | eapply tri_bot;auto ].
      ++  (* PAR *)
        apply IH with (m:= complexity F0 + complexity  G + complexityL  L) in H5;auto.
        destruct H5 as [n'  [IHn IHd]].
        exists (S n').
        firstorder ;[lia | eapply tri_par;auto ].
        simpl. lia.
      ++ (* with *)
        apply IH with (m:= complexity  F0 + complexityL  L) in H6;try lia;auto.
        apply IH with (m:= complexity  G + complexityL L) in H7;try lia;auto.
        destruct H6 as [n'  [IHn IHd]].
        destruct H7 as [m'  [IHn' IHd']].
        simpl.
        exists (S (S n0)).
        firstorder; eapply tri_with;auto.
        eapply HeightGeq with (n:=n');try firstorder.
       eapply HeightGeq with (n:=m');try firstorder.
      ++  (* quest *)
        apply IH with (m:= complexityL  L) in H5;auto.
        destruct H5 as [n'  [IHn IHd]].
        exists (S n').
        firstorder ;[lia | eapply tri_quest;auto ].
        lia.
      ++ (* Store *)
        assert(exists m0 : nat, m0 <= S n0 /\ m0 |--- B; M ++ [o]; UP (L ++ [F])).
        apply IH with (m:= complexityL L);auto.
        assert (complexity o > 0) by (apply Complexity0);lia.
        eapply exchangeLCN;[|exact H7].
        perm.

        destruct H1 as [n'  [IHn IHd]].
        exists (S n').
        firstorder ;[lia | eapply tri_store;[auto | LLExact IHd] ].
     ++  (* FORALL *)
        assert(forall x, proper x -> exists m, m <= S n0 /\  m |--- B; M; UP ((FX x :: L)  ++ [F])).
        intros.
        generalize (H7 x H1);intro.
        eapply IH with (m:=complexity (FX x) + complexityL L);auto.
        assert(complexity (FX (VAR con 0%nat)) = complexity (FX x) ).

        apply ComplexityUniformEq;auto.

        constructor.
        lia.

        simpl.
        exists (S (S n0)).
        split ; [auto|eapply tri_fx;auto;intros].

        generalize (H1 _ H2);intro.

        destruct H3 as [n H3].
        destruct H3 as [H3 H3'].
        eapply @HeightGeq with (n:=n);try firstorder.

  Qed.

    Lemma UpExtension': forall B M L F,
      positiveLFormula F ->
      (|-- B; F::M ; UP L) -> |-- B; M ; UP (L ++ [F]).
  Proof with sauto.
  intros.
  apply seqtoSeqN in H0.
  destruct H0.
  apply UpExtension in H0...
  apply seqNtoSeq in H2...
  Qed.

(* Lemma UpExtensionInv n F B M L :
     n |---  B ; M ; (UP (L++[F])) -> |-- B ; F::M; (UP L).
  Proof with sauto;solveF;try solveLL.
  intros.

  revert dependent F.
  revert B M L.
  induction n using strongind;intros...
  + inversion H...
    apply ListConsApp in H4...
    LFocus. Print positiveFormula. constructor.
  + inversion H0...
    -
    apply ListConsApp in H5...
    decide1 top M.
    -
    apply ListConsApp in H2...
    decide1 bot M.
    apply seqNtoSeq in H5...
    eapply H in H5...
    -
    apply ListConsApp in H2...
    decide1 (F0 $ G) M.
    apply seqNtoSeq in H5...
    rewrite app_comm_cons in H5.
    rewrite app_comm_cons in H5.
    eapply H in H5...
    -
    apply ListConsApp in H2...
    decide1 (F0 & G) M.
    apply seqNtoSeq in H3...
    apply seqNtoSeq in H6...
    rewrite app_comm_cons in H3.
    eapply H in H3...
    rewrite app_comm_cons in H6.
    eapply H in H6...
    -
    apply ListConsApp in H2...
    decide1 (i ? F0) M.
    apply seqNtoSeq in H5...
    eapply H in H5...
    -
    apply ListConsApp in H2...
    apply seqNtoSeq in H6;auto.
    eapply H in H6...
    LLExact H6.
    -
    apply ListConsApp in H2...
    decide1 (F{ FX}) M.
    apply H6 in properX...
    apply seqNtoSeq in properX...
    apply H6 in properX...
    rewrite app_comm_cons in properX.
    eapply H in properX...
 Qed.

Lemma UpExtensionInvN n F B M L :
     n |---  B ; M ; (UP (L++[F])) -> S (S n) |--- B ; F::M; (UP L).
  Proof with sauto;solveF;solveLL.
  intros.
  revert dependent F.
  revert B M L.
  induction n using strongind;intros...
  + inversion H...
    apply ListConsApp in H4...
    decide1 top M.
  + inversion H0...
    -
    apply ListConsApp in H5...
    decide1 top M.
    -
    apply ListConsApp in H2...
    decide1 bot M.
    -
    apply ListConsApp in H2...
    decide1 (F0 $ G) M.
    -
    apply ListConsApp in H2...
    decide1 (F0 & G) M.
    -
    apply ListConsApp in H2...
    decide1 (i ? F0) M.
    -
    apply ListConsApp in H2...
    LLExact H6.
    apply (exchangeLCN (perm_swap F0 F M))...
    -
    apply ListConsApp in H2...
    decide1 (F{ FX}) M.
    apply H6 in properX...
 Qed.

  Lemma UpExtensionInv' F B M L :
       |--  B ; M ; (UP (L++[F])) -> |-- B ; F::M; (UP L).
  Proof with sauto.
  intros.
  apply seqtoSeqN in H.
  destruct H.
  apply UpExtensionInv in H...
  Qed.
 *)

(* Lemma UpExtensionInv2 n F B M L1 L2 :
   positiveLFormula F ->  n |---  B ; M ; (UP (L1++[F]++L2)) -> |-- B ; F::M; (UP (L1++L2)).
  Proof with sauto;solveF;try solveLL.
  intros.
  apply UpExtensionInv'.

  rewrite app_assoc_reverse.
  revert dependent F.
  revert B M L1 L2.
  induction n using strongind;intros...
  + inversion H0...
    apply ListConsApp' in H5...
  + inversion H1...
    -
    apply ListConsApp' in H6...
    -
    apply ListConsApp' in H3...
    eapply H in H6...
    -
    apply ListConsApp' in H3...
    rewrite app_comm_cons in H6.
    rewrite app_comm_cons in H6.
    eapply H in H6...
    -
    apply ListConsApp' in H3...
    rewrite app_comm_cons in H4.
    eapply H in H4...
    rewrite app_comm_cons in H7.
    eapply H in H7...
    -
    apply ListConsApp' in H3...
    eapply H in H6...
    -
    apply ListConsApp' in H3...
    apply seqNtoSeq in H7...
    apply UpExtension';auto.
    eapply H in H7...
    -
    apply ListConsApp' in H3...
    apply H7 in properX...
    rewrite app_comm_cons in properX.
    eapply H in properX...
 Qed.
 *)
End InvNPhase.


From stbor.sim Require Import left_step right_step.

Lemma sim_body_copy_local fs ft r r' n l t ty ss st σs σt Φ :
  tsize ty = 1%nat →
  r ≡ r' ⋅ res_loc l [(ss, st)] t →
  (r ⊨{n,fs,ft} (#[ss], σs) ≥ (#[st], σt) : Φ) →
  r ⊨{S n,fs,ft}
    (Copy (Place l (Tagged t) ty), σs) ≥ (Copy (Place l (Tagged t) ty), σt)
  : Φ.
Proof.
  intros ?? Hcont.
  eapply sim_body_copy_local_l; [done..|].
  eapply sim_body_copy_local_r; done.
Qed.


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

Require Import Coq.micromega.Lia.
Require Import Cava.Cava.
Local Open Scope vector_scope.

Section WithCava.
  Context {signal} `{Cava signal}.

  Definition twoSorter {signal} `{Cava signal} {n}
                     (ab:  signal (Vec (Vec Bit n) 2)) :
                     cava (signal (Vec (Vec Bit n) 2)) :=
   a <- indexConst ab 0 ;;
   b <- indexConst ab 1 ;;
   comparison <- greaterThanOrEqual (a, b) ;;
   negComparison <- inv comparison ;;
   out0 <- mux2 comparison (a, b) ;;
   out1 <- mux2 negComparison (a, b) ;;
   packV [out0; out1].

End WithCava.

Definition two_sorter_Interface bitSize
  := combinationalInterface "two_sorter"
     [mkPort "inputs" (Vec (Vec Bit bitSize) 2)]
     [mkPort "sorted" (Vec (Vec Bit bitSize) 2)].

Definition two_sorter_Netlist
  := makeNetlist (two_sorter_Interface 8) twoSorter.

Definition v0 := N2Bv_sized 8   5.
Definition v1 := N2Bv_sized 8 157.
Definition v2 := N2Bv_sized 8 255.
Definition v3 := N2Bv_sized 8  63.

Definition two_sorter_tb_inputs : list (Vector.t (Bvector 8) _) :=
  [[v0; v1];
   [v1; v0];
   [v1; v2];
   [v2; v1];
   [v2; v3];
   [v3; v2]
  ].

Definition two_sorter_tb_expected_outputs : list (Vector.t (Bvector 8) _) :=
  simulate (Comb twoSorter) two_sorter_tb_inputs.

Definition two_sorter_tb :=
  testBench "two_sorter_tb" (two_sorter_Interface 8)
  two_sorter_tb_inputs two_sorter_tb_expected_outputs.

Definition twoSorterSpec {bw: nat} (ab : Vector.t (Bvector bw) 2) :
                                   Vector.t (Bvector bw) 2 :=
  let a := @Vector.nth_order _ 2 ab 0 (ltac:(lia)) in
  let b := @Vector.nth_order _ 2 ab 1 (ltac:(lia)) in
  if (Bv2N b <=? Bv2N a)%N then
    [b; a]
  else
    [a; b].

Lemma twoSorterCorrect {bw : nat} (v : Vector.t (Bvector bw) 2) :
  @twoSorter combType _ _ v = twoSorterSpec v.
Proof.
  constant_vector_simpl v.
  cbv [twoSorterSpec twoSorter Vector.nth_order].
  simpl.
  destruct (Bv2N _ <=? Bv2N _)%N; try reflexivity.
Qed.


Require Import Crypto.Compilers.Syntax.
Require Import Crypto.Compilers.Eta.
Require Import Crypto.Compilers.ExprInversion.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.DestructHead.

Section language.
  Context {base_type_code : Type}
          {interp_base_type : base_type_code -> Type}
          {op : flat_type base_type_code -> flat_type base_type_code -> Type}
          {interp_op : forall src dst, op src dst -> interp_flat_type interp_base_type src -> interp_flat_type interp_base_type dst}.

  Local Notation exprf := (@exprf base_type_code op interp_base_type).

  Local Ltac t_step :=
    match goal with
    | _ => reflexivity
    | _ => progress simpl in *
    | _ => intro
    | _ => progress break_match
    | _ => progress destruct_head prod
    | _ => progress cbv [LetIn.Let_In]
    | [ H : _ |- _ ] => rewrite H
    | _ => progress autorewrite with core
    | [ H : forall A B x, ?f A B x = x, H' : context[?f _ _ _] |- _ ]
      => rewrite H in H'
    | _ => progress unfold interp_flat_type_eta, interp_flat_type_eta', exprf_eta, exprf_eta', expr_eta, expr_eta'
    end.
  Local Ltac t := repeat t_step.

  Section gen_flat_type.
    Context (eta : forall {A B}, A * B -> A * B)
            (eq_eta : forall A B x, @eta A B x = x).
    Lemma eq_interp_flat_type_eta_gen {var t T f} x
      : @interp_flat_type_eta_gen base_type_code var eta t T f x = f x.
    Proof using eq_eta. induction t; t. Qed.

    (* Local *) Hint Rewrite @eq_interp_flat_type_eta_gen.

    Section gen_type.
      Context (exprf_eta : forall {t} (e : exprf t), exprf t)
              (eq_interp_exprf_eta : forall t e, interpf (@interp_op) (@exprf_eta t e) = interpf (@interp_op) e).
      Lemma interp_expr_eta_gen {t e}
        : forall x,
          interp (@interp_op) (expr_eta_gen eta exprf_eta (t:=t) e) x = interp (@interp_op) e x.
      Proof using Type*. t. Qed.
    End gen_type.
    (* Local *) Hint Rewrite @interp_expr_eta_gen.

    Lemma interpf_exprf_eta_gen {t e}
      : interpf (@interp_op) (exprf_eta_gen eta (t:=t) e) = interpf (@interp_op) e.
    Proof using eq_eta. induction e; t. Qed.

    Lemma InterpExprEtaGen {t e}
      : forall x, Interp (@interp_op) (ExprEtaGen eta (t:=t) e) x = Interp (@interp_op) e x.
    Proof using eq_eta. apply interp_expr_eta_gen; intros; apply interpf_exprf_eta_gen. Qed.
  End gen_flat_type.
  (* Local *) Hint Rewrite @eq_interp_flat_type_eta_gen.
  (* Local *) Hint Rewrite @interp_expr_eta_gen.
  (* Local *) Hint Rewrite @interpf_exprf_eta_gen.

  Lemma eq_interp_flat_type_eta {var t T f} x
    : @interp_flat_type_eta base_type_code var t T f x = f x.
  Proof using Type. t. Qed.
  (* Local *) Hint Rewrite @eq_interp_flat_type_eta.
  Lemma eq_interp_flat_type_eta' {var t T f} x
    : @interp_flat_type_eta' base_type_code var t T f x = f x.
  Proof using Type. t. Qed.
  (* Local *) Hint Rewrite @eq_interp_flat_type_eta'.
  Lemma interpf_exprf_eta {t e}
    : interpf (@interp_op) (exprf_eta (t:=t) e) = interpf (@interp_op) e.
  Proof using Type. t. Qed.
  (* Local *) Hint Rewrite @interpf_exprf_eta.
  Lemma interpf_exprf_eta' {t e}
    : interpf (@interp_op) (exprf_eta' (t:=t) e) = interpf (@interp_op) e.
  Proof using Type. t. Qed.
  (* Local *) Hint Rewrite @interpf_exprf_eta'.
  Lemma interp_expr_eta {t e}
    : forall x, interp (@interp_op) (expr_eta (t:=t) e) x = interp (@interp_op) e x.
  Proof using Type. t. Qed.
  Lemma interp_expr_eta' {t e}
    : forall x, interp (@interp_op) (expr_eta' (t:=t) e) x = interp (@interp_op) e x.
  Proof using Type. t. Qed.
  Lemma InterpExprEta {t e}
    : forall x, Interp (@interp_op) (ExprEta (t:=t) e) x = Interp (@interp_op) e x.
  Proof using Type. apply interp_expr_eta. Qed.
  Lemma InterpExprEta' {t e}
    : forall x, Interp (@interp_op) (ExprEta' (t:=t) e) x = Interp (@interp_op) e x.
  Proof using Type. apply interp_expr_eta'. Qed.
  Lemma InterpExprEta_arrow {s d e}
    : forall x, Interp (t:=Arrow s d) (@interp_op) (ExprEta (t:=Arrow s d) e) x = Interp (@interp_op) e x.
  Proof using Type. exact (@InterpExprEta (Arrow s d) e). Qed.
  Lemma InterpExprEta'_arrow {s d e}
    : forall x, Interp (t:=Arrow s d) (@interp_op) (ExprEta' (t:=Arrow s d) e) x = Interp (@interp_op) e x.
  Proof using Type. exact (@InterpExprEta' (Arrow s d) e). Qed.

  Lemma InterpExprEta_ind {t} (P : _ -> Prop) {e x}
    : P (Interp (@interp_op) e x) -> P (Interp (@interp_op) (ExprEta (t:=t) e) x).
  Proof using Type. rewrite InterpExprEta; exact id. Qed.
  Lemma InterpExprEta'_ind {t} (P : _ -> Prop) {e x}
    : P (Interp (@interp_op) e x) -> P (Interp (@interp_op) (ExprEta' (t:=t) e) x).
  Proof using Type. rewrite InterpExprEta'; exact id. Qed.
  Lemma InterpExprEta_arrow_ind {s d} (P : _ -> Prop) {e x}
    : P (Interp (@interp_op) e x) -> P (Interp (t:=Arrow s d) (@interp_op) (ExprEta (t:=Arrow s d) e) x).
  Proof using Type. rewrite InterpExprEta_arrow; exact id. Qed.
  Lemma InterpExprEta'_arrow_ind {s d} (P : _ -> Prop) {e x}
    : P (Interp (@interp_op) e x) -> P (Interp (t:=Arrow s d) (@interp_op) (ExprEta' (t:=Arrow s d) e) x).
  Proof using Type. rewrite InterpExprEta'_arrow; exact id. Qed.

  Lemma eq_interp_eta {t e}
    : forall x, interp_eta interp_op (t:=t) e x = interp interp_op e x.
  Proof using Type. apply eq_interp_flat_type_eta. Qed.
  Lemma eq_InterpEta {t e}
    : forall x, InterpEta interp_op (t:=t) e x = Interp interp_op e x.
  Proof using Type. apply eq_interp_eta. Qed.
End language.

Hint Rewrite @eq_interp_flat_type_eta @eq_interp_flat_type_eta' @interpf_exprf_eta @interpf_exprf_eta' @interp_expr_eta @interp_expr_eta' @InterpExprEta @InterpExprEta' @InterpExprEta_arrow @InterpExprEta'_arrow @eq_interp_eta @eq_InterpEta : reflective_interp.


Require Import Coq.ZArith.BinInt coqutil.Z.Lia.
Require Import coqutil.Word.Interface coqutil.Map.Interface.
Require coqutil.Map.SortedList.

Section __. Local Set Default Proof Using "All".
  Context {width} (word : word width) {word_ok : @word.ok width word}.
  Global Instance strict_order_word
    : SortedList.parameters.strict_order (T:=word) word.ltu.
  Proof.
    split; try setoid_rewrite word.unsigned_ltu; intros;
      repeat match goal with
             | H: context[Z.ltb ?a ?b] |- _ => destruct (Z.ltb_spec a b)
             | |- context[Z.ltb ?a ?b] => destruct (Z.ltb_spec a b)
             end; try congruence; try blia; [].
    rewrite <-word.of_Z_unsigned; rewrite <-word.of_Z_unsigned at 1; f_equal.
    blia.
  Qed.

  Context (value : Type).
  Definition SortedList_parameters : SortedList.parameters :=
    {| SortedList.parameters.value := value;
       SortedList.parameters.key := word;
       SortedList.parameters.ltb := word.ltu |}.
  Definition map : map.map word value := SortedList.map SortedList_parameters strict_order_word.
  Global Instance ok : map.ok map := @SortedList.map_ok SortedList_parameters strict_order_word.
End __.


From sflib Require Import sflib.
From Paco Require Import paco.
Require Export Coq.Strings.String.
Require Import Coq.Classes.RelationClasses.

From Fairness Require Export ITreeLib FairBeh Mod.
From Fairness Require Import pind LPCM WFLib.
From Fairness Require Import ModSim.

Set Implicit Arguments.

Section PRIMIVIESIM.
  Context `{M: URA.t}.

  Variable state_src: Type.
  Variable state_tgt: Type.

  Variable ident_src: ID.
  Variable _ident_tgt: ID.
  Let ident_tgt := @ident_tgt _ident_tgt.

  Variable wf_src: WF.
  Variable wf_tgt: WF.

  Let srcE := programE ident_src state_src.
  Let tgtE := programE _ident_tgt state_tgt.

  Let shared := shared state_src state_tgt ident_src _ident_tgt wf_src wf_tgt.

  Let shared_rel: Type := shared -> Prop.

  Variable I: shared -> URA.car -> Prop.

  Variant __lsim
          (tid: thread_id)
          (lsim: forall R_src R_tgt (RR: R_src -> R_tgt -> URA.car -> shared_rel), bool -> bool -> URA.car -> itree srcE R_src -> itree tgtE R_tgt -> shared_rel)
          (_lsim: forall R_src R_tgt (RR: R_src -> R_tgt -> URA.car -> shared_rel),bool -> bool -> URA.car -> itree srcE R_src -> itree tgtE R_tgt -> shared_rel)
          R_src R_tgt (RR: R_src -> R_tgt -> URA.car -> shared_rel)
    :
    bool -> bool -> URA.car -> itree srcE R_src -> itree tgtE R_tgt -> shared_rel :=
  | lsim_ret
      f_src f_tgt r_ctx
      ths im_src im_tgt st_src st_tgt
      r_src r_tgt
      (LSIM: RR r_src r_tgt r_ctx (ths, im_src, im_tgt, st_src, st_tgt))
    :
    __lsim tid lsim _lsim RR f_src f_tgt r_ctx (Ret r_src) (Ret r_tgt) (ths, im_src, im_tgt, st_src, st_tgt)

  | lsim_tauL
      f_src f_tgt r_ctx
      ths im_src im_tgt st_src st_tgt
      itr_src itr_tgt
      (LSIM: _lsim _ _ RR true f_tgt r_ctx itr_src itr_tgt (ths, im_src, im_tgt, st_src, st_tgt))
    :
    __lsim tid lsim _lsim RR f_src f_tgt r_ctx (Tau itr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt)
  | lsim_chooseL
      f_src f_tgt r_ctx
      ths im_src im_tgt st_src st_tgt
      X ktr_src itr_tgt
      (LSIM: exists x, _lsim _ _ RR true f_tgt r_ctx (ktr_src x) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt))
    :
    __lsim tid lsim _lsim RR f_src f_tgt r_ctx (trigger (Choose X) >>= ktr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt)
  | lsim_rmwL
      f_src f_tgt r_ctx
      ths im_src im_tgt st_src st_tgt
      X rmw ktr_src itr_tgt
      (LSIM: _lsim _ _ RR true f_tgt r_ctx (ktr_src (snd (rmw st_src) : X)) itr_tgt (ths, im_src, im_tgt, fst (rmw st_src), st_tgt))
    :
    __lsim tid lsim _lsim RR f_src f_tgt r_ctx (trigger (Rmw rmw) >>= ktr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt)
  | lsim_tidL
      f_src f_tgt r_ctx
      ths im_src im_tgt st_src st_tgt
      ktr_src itr_tgt
      (LSIM: _lsim _ _ RR true f_tgt r_ctx (ktr_src tid) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt))
    :
    __lsim tid lsim _lsim RR f_src f_tgt r_ctx (trigger (GetTid) >>= ktr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt)
  | lsim_UB
      f_src f_tgt r_ctx
      ths im_src im_tgt st_src st_tgt
      ktr_src itr_tgt
    :
    __lsim tid lsim _lsim RR f_src f_tgt r_ctx (trigger (Undefined) >>= ktr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt)
  | lsim_fairL
      f_src f_tgt r_ctx
      ths im_src0 im_tgt st_src st_tgt
      f ktr_src itr_tgt
      (LSIM: exists im_src1,
          (<<FAIR: fair_update im_src0 im_src1 f>>) /\
            (<<LSIM: _lsim _ _ RR true f_tgt r_ctx (ktr_src tt) itr_tgt (ths, im_src1, im_tgt, st_src, st_tgt)>>))
    :
    __lsim tid lsim _lsim RR f_src f_tgt r_ctx (trigger (Fair f) >>= ktr_src) itr_tgt (ths, im_src0, im_tgt, st_src, st_tgt)

  | lsim_tauR
      f_src f_tgt r_ctx
      ths im_src im_tgt st_src st_tgt
      itr_src itr_tgt
      (LSIM: _lsim _ _ RR f_src true r_ctx itr_src itr_tgt (ths, im_src, im_tgt, st_src, st_tgt))
    :
    __lsim tid lsim _lsim RR f_src f_tgt r_ctx itr_src (Tau itr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
  | lsim_chooseR
      f_src f_tgt r_ctx
      ths im_src im_tgt st_src st_tgt
      X itr_src ktr_tgt
      (LSIM: forall x, _lsim _ _ RR f_src true r_ctx itr_src (ktr_tgt x) (ths, im_src, im_tgt, st_src, st_tgt))
    :
    __lsim tid lsim _lsim RR f_src f_tgt r_ctx itr_src (trigger (Choose X) >>= ktr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
  | lsim_rmwR
      f_src f_tgt r_ctx
      ths im_src im_tgt st_src st_tgt
      X rmw itr_src ktr_tgt
      (LSIM: _lsim _ _ RR f_src true r_ctx itr_src (ktr_tgt (snd (rmw st_tgt) : X)) (ths, im_src, im_tgt, st_src, fst (rmw st_tgt)))
    :
    __lsim tid lsim _lsim RR f_src f_tgt r_ctx itr_src (trigger (Rmw rmw) >>= ktr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
  | lsim_tidR
      f_src f_tgt r_ctx
      ths im_src im_tgt st_src st_tgt
      itr_src ktr_tgt
      (LSIM: _lsim _ _ RR f_src true r_ctx itr_src (ktr_tgt tid) (ths, im_src, im_tgt, st_src, st_tgt))
    :
    __lsim tid lsim _lsim RR f_src f_tgt r_ctx itr_src (trigger (GetTid) >>= ktr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
  | lsim_fairR
      f_src f_tgt r_ctx
      ths im_src im_tgt0 st_src st_tgt
      f itr_src ktr_tgt
      (LSIM: forall im_tgt1
                   (FAIR: fair_update im_tgt0 im_tgt1 (prism_fmap inrp f)),
          (<<LSIM: _lsim _ _ RR f_src true r_ctx itr_src (ktr_tgt tt) (ths, im_src, im_tgt1, st_src, st_tgt)>>))
    :
    __lsim tid lsim _lsim RR f_src f_tgt r_ctx itr_src (trigger (Fair f) >>= ktr_tgt) (ths, im_src, im_tgt0, st_src, st_tgt)

  | lsim_observe
      f_src f_tgt r_ctx
      ths im_src im_tgt st_src st_tgt
      fn args ktr_src ktr_tgt
      (LSIM: forall ret,
          _lsim _ _ RR true true r_ctx (ktr_src ret) (ktr_tgt ret) (ths, im_src, im_tgt, st_src, st_tgt))
    :
    __lsim tid lsim _lsim RR f_src f_tgt r_ctx (trigger (Observe fn args) >>= ktr_src) (trigger (Observe fn args) >>= ktr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)

  | lsim_call
      f_src f_tgt r_ctx
      ths im_src im_tgt st_src st_tgt
      fn args ktr_src itr_tgt
    : __lsim tid lsim _lsim RR f_src f_tgt r_ctx (trigger (Call fn args) >>= ktr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt)

  | lsim_yieldL
      f_src f_tgt r_ctx
      ths im_src im_tgt st_src st_tgt
      ktr_src itr_tgt
      (LSIM: _lsim _ _ RR true f_tgt r_ctx (ktr_src tt) (trigger (Yield) >>= itr_tgt) (ths, im_src, im_tgt, st_src, st_tgt))
    :
    __lsim tid lsim _lsim RR f_src f_tgt r_ctx (trigger (Yield) >>= ktr_src) (trigger (Yield) >>= itr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
  | lsim_yieldR
      f_src f_tgt r_ctx0
      ths0 im_src0 im_tgt0 st_src0 st_tgt0
      r_own r_shared
      ktr_src ktr_tgt
      (INV: I (ths0, im_src0, im_tgt0, st_src0, st_tgt0) r_shared)
      (VALID: URA.wf (r_shared ⋅ r_own ⋅ r_ctx0))
      (LSIM: forall ths1 im_src1 im_tgt1 st_src1 st_tgt1 r_shared1 r_ctx1
                    (INV: I (ths1, im_src1, im_tgt1, st_src1, st_tgt1) r_shared1)
                    (VALID: URA.wf (r_shared1 ⋅ r_own ⋅ r_ctx1))
                    im_tgt2
                    (TGT: fair_update im_tgt1 im_tgt2 (prism_fmap inlp (tids_fmap tid ths1))),
          _lsim _ _ RR f_src true r_ctx1 (trigger (Yield) >>= ktr_src) (ktr_tgt tt) (ths1, im_src1, im_tgt2, st_src1, st_tgt1))
    :
    __lsim tid lsim _lsim RR f_src f_tgt r_ctx0 (trigger (Yield) >>= ktr_src) (trigger (Yield) >>= ktr_tgt) (ths0, im_src0, im_tgt0, st_src0, st_tgt0)
  | lsim_sync
      f_src f_tgt r_ctx0
      ths0 im_src0 im_tgt0 st_src0 st_tgt0
      r_own r_shared
      ktr_src ktr_tgt
      (INV: I (ths0, im_src0, im_tgt0, st_src0, st_tgt0) r_shared)
      (VALID: URA.wf (r_shared ⋅ r_own ⋅ r_ctx0))
      (LSIM: forall ths1 im_src1 im_tgt1 st_src1 st_tgt1 r_shared1 r_ctx1
               (INV: I (ths1, im_src1, im_tgt1, st_src1, st_tgt1) r_shared1)
               (VALID: URA.wf (r_shared1 ⋅ r_own ⋅ r_ctx1))
               im_tgt2
               (TGT: fair_update im_tgt1 im_tgt2 (prism_fmap inlp (tids_fmap tid ths1))),
          (<<LSIM: _lsim _ _ RR true true r_ctx1 (ktr_src tt) (ktr_tgt tt) (ths1, im_src1, im_tgt2, st_src1, st_tgt1)>>))
    :
    __lsim tid lsim _lsim RR f_src f_tgt r_ctx0 (trigger (Yield) >>= ktr_src) (trigger (Yield) >>= ktr_tgt) (ths0, im_src0, im_tgt0, st_src0, st_tgt0)

  | lsim_progress
      r_ctx
      ths im_src im_tgt st_src st_tgt
      itr_src itr_tgt
      (LSIM: lsim _ _ RR false false r_ctx itr_src itr_tgt (ths, im_src, im_tgt, st_src, st_tgt))
    :
    __lsim tid lsim _lsim RR true true r_ctx itr_src itr_tgt (ths, im_src, im_tgt, st_src, st_tgt)
  .

  Definition lsim (tid: thread_id)
             R_src R_tgt (RR: R_src -> R_tgt -> URA.car -> shared_rel):
    bool -> bool -> URA.car -> itree srcE R_src -> itree tgtE R_tgt -> shared_rel :=
    paco9 (fun r => pind9 (__lsim tid r) top9) bot9 R_src R_tgt RR.

  Lemma __lsim_mon tid:
    forall r r' (LE: r <9= r'), (__lsim tid r) <10= (__lsim tid r').
  Proof.
    ii. inv PR; try (econs; eauto; fail).
  Qed.

  Lemma _lsim_mon tid: forall r, monotone9 (__lsim tid r).
  Proof.
    ii. inv IN; try (econs; eauto; fail).
    { des. econs; eauto. }
    { des. econs; eauto. }
    { econs. i. eapply LE. eapply LSIM. eauto. }
    { eapply lsim_sync; eauto. i. eapply LE. eapply LSIM; eauto. }
  Qed.

  Lemma lsim_mon tid: forall q, monotone9 (fun r => pind9 (__lsim tid r) q).
  Proof.
    ii. eapply pind9_mon_gen; eauto.
    ii. eapply __lsim_mon; eauto.
  Qed.

  Local Hint Constructors __lsim: core.
  Local Hint Unfold lsim: core.
  Local Hint Resolve __lsim_mon: paco.
  Local Hint Resolve _lsim_mon: paco.
  Local Hint Resolve lsim_mon: paco.

  Lemma modsim_implies_gensim
        tid
        R0 R1 (RR: R0 -> R1 -> URA.car -> shared_rel)
        ps pt r_ctx src tgt
        (shr: shared)
        (LSIM: ModSim.lsim I tid RR ps pt r_ctx src tgt shr)
    :
    lsim tid RR ps pt r_ctx src tgt shr.
  Proof.
    revert_until tid. pcofix CIH; i.
    punfold LSIM.
    pattern R0, R1, RR, ps, pt, r_ctx, src, tgt, shr.
    revert R0 R1 RR ps pt r_ctx src tgt shr LSIM. apply pind9_acc.
    intros rr DEC IH. clear DEC. intros R0 R1 RR ps pt r_ctx src tgt shr LSIM.
    eapply pind9_unfold in LSIM.
    2:{ eapply ModSim._lsim_mon. }
    inv LSIM.

    { pfold. eapply pind9_fold. eapply lsim_ret; eauto. }
    { pfold. eapply pind9_fold. eapply lsim_tauL; eauto.
      split; ss. destruct LSIM0 as [LSIM IND]. eapply IH in IND. punfold IND.
    }
    { pfold. eapply pind9_fold. eapply lsim_chooseL; eauto.
      des. exists x.
      split; ss. destruct LSIM0 as [LSIM IND]. eapply IH in IND. punfold IND.
    }
    { pfold. eapply pind9_fold. eapply lsim_rmwL; eauto.
      split; ss. destruct LSIM0 as [LSIM IND]. eapply IH in IND. punfold IND.
    }
    { pfold. eapply pind9_fold. eapply lsim_tidL; eauto.
      split; ss. destruct LSIM0 as [LSIM IND]. eapply IH in IND. punfold IND.
    }
    { pfold. eapply pind9_fold. eapply lsim_UB; eauto. }
    { pfold. eapply pind9_fold. eapply lsim_fairL; eauto.
      des. esplits; eauto.
      split; ss. destruct LSIM as [LSIM IND]. eapply IH in IND. punfold IND.
    }
    { pfold. eapply pind9_fold. eapply lsim_tauR; eauto.
      split; ss. destruct LSIM0 as [LSIM IND]. eapply IH in IND. punfold IND.
    }
    { pfold. eapply pind9_fold. eapply lsim_chooseR; eauto.
      i. specialize (LSIM0 x).
      split; ss. destruct LSIM0 as [LSIM IND]. eapply IH in IND. punfold IND.
    }
    { pfold. eapply pind9_fold. eapply lsim_rmwR; eauto.
      split; ss. destruct LSIM0 as [LSIM IND]. eapply IH in IND. punfold IND.
    }
    { pfold. eapply pind9_fold. eapply lsim_tidR; eauto.
      split; ss. destruct LSIM0 as [LSIM IND]. eapply IH in IND. punfold IND.
    }
    { pfold. eapply pind9_fold. eapply lsim_fairR; eauto.
      i. specialize (LSIM0 _ FAIR).
      split; ss. destruct LSIM0 as [LSIM IND]. eapply IH in IND. punfold IND.
    }

    { pfold. eapply pind9_fold. eapply lsim_observe; eauto.
      i. specialize (LSIM0 ret). pclearbot.
      split; ss. eapply pind9_fold. eapply lsim_progress.
      right. eapply CIH; eauto. eapply ModSim.lsim_set_prog. auto.
    }

    { pfold. eapply pind9_fold. eapply lsim_call. }

    { pfold. eapply pind9_fold. eapply lsim_yieldL.
      des. esplits; eauto.
      split; ss. destruct LSIM0 as [LSIM IND]. eapply IH in IND. punfold IND.
    }

    { pfold. eapply pind9_fold. eapply lsim_yieldR; eauto.
      i. specialize (LSIM0 _ _ _ _ _ _ _ INV0 VALID0 _ TGT).
      split; ss. destruct LSIM0 as [LSIM IND]. eapply IH in IND. punfold IND.
    }

    { pfold. eapply pind9_fold. eapply lsim_sync; eauto.
      i. specialize (LSIM0 _ _ _ _ _ _ _ INV0 VALID0 _ TGT).
      split; ss. eapply pind9_fold. eapply lsim_progress. pclearbot.
      right. eapply CIH. apply ModSim.lsim_set_prog; auto.
    }

    { pfold. eapply pind9_fold. eapply lsim_progress. right.
      eapply CIH. pclearbot. auto.
    }

  Qed.

End PRIMIVIESIM.
#[export] Hint Constructors __lsim: core.
#[export] Hint Unfold lsim: core.
#[export] Hint Resolve __lsim_mon: paco.
#[export] Hint Resolve _lsim_mon: paco.
#[export] Hint Resolve lsim_mon: paco.

Section GENORDER.
  Context `{M: URA.t}.

  Variable state_src: Type.
  Variable state_tgt: Type.

  Variable ident_src: ID.
  Variable _ident_tgt: ID.
  Let ident_tgt := @ident_tgt _ident_tgt.

  Variable wf_src: WF.
  Variable wf_tgt: WF.

  Let srcE := programE ident_src state_src.
  Let tgtE := programE _ident_tgt state_tgt.

  Let shared := shared state_src state_tgt ident_src _ident_tgt wf_src wf_tgt.
  Let shared_rel: Type := shared -> Prop.
  Variable I: shared -> URA.car -> Prop.

  Let A R0 R1 := (bool * bool * URA.car * (itree srcE R0) * (itree tgtE R1) * shared)%type.
  Let wf_stt R0 R1 := @ord_tree_WF (A R0 R1).

  Variant _genos
          (tid: thread_id)
          (genos: forall R0 R1 (RR: R0 -> R1 -> URA.car -> shared_rel), bool -> bool -> URA.car -> ((wf_stt R0 R1).(T) * itree srcE R0) -> ((wf_stt R0 R1).(T) * itree tgtE R1) -> shared_rel)
          R0 R1 (RR: R0 -> R1 -> URA.car -> shared_rel)
    :
    bool -> bool -> URA.car -> ((wf_stt R0 R1).(T) * itree srcE R0) -> ((wf_stt R0 R1).(T) * itree tgtE R1) -> shared_rel :=
  | genos_ret
      f_src f_tgt r_ctx os ot
      ths im_src im_tgt st_src st_tgt
      r_src r_tgt
      (GENOS: RR r_src r_tgt r_ctx (ths, im_src, im_tgt, st_src, st_tgt))
    :
    _genos tid genos RR f_src f_tgt r_ctx (os, Ret r_src) (ot, Ret r_tgt) (ths, im_src, im_tgt, st_src, st_tgt)

  | genos_tauL
      f_src f_tgt r_ctx os ot
      ths im_src im_tgt st_src st_tgt
      itr_src itr_tgt
      (GENOS: genos _ _ RR true f_tgt r_ctx (os, itr_src) (ot, itr_tgt) (ths, im_src, im_tgt, st_src, st_tgt))
    :
    _genos tid genos RR f_src f_tgt r_ctx (os, Tau itr_src) (ot, itr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
  | genos_chooseL
      f_src f_tgt r_ctx os ot
      ths im_src im_tgt st_src st_tgt
      X ktr_src itr_tgt
      (GENOS: exists x, genos _ _ RR true f_tgt r_ctx (os, ktr_src x) (ot, itr_tgt) (ths, im_src, im_tgt, st_src, st_tgt))
    :
    _genos tid genos RR f_src f_tgt r_ctx (os, trigger (Choose X) >>= ktr_src) (ot, itr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
  | genos_rmwL
      f_src f_tgt r_ctx os ot
      ths im_src im_tgt st_src st_tgt
      X rmw ktr_src itr_tgt
      (GENOS: genos _ _ RR true f_tgt r_ctx (os, ktr_src (snd (rmw st_src) : X)) (ot, itr_tgt) (ths, im_src, im_tgt, fst (rmw st_src), st_tgt))
    :
    _genos tid genos RR f_src f_tgt r_ctx (os, trigger (Rmw rmw) >>= ktr_src) (ot, itr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
  | genos_tidL
      f_src f_tgt r_ctx os ot
      ths im_src im_tgt st_src st_tgt
      ktr_src itr_tgt
      (GENOS: genos _ _ RR true f_tgt r_ctx (os, ktr_src tid) (ot, itr_tgt) (ths, im_src, im_tgt, st_src, st_tgt))
    :
    _genos tid genos RR f_src f_tgt r_ctx (os, trigger (GetTid) >>= ktr_src) (ot, itr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
  | genos_UB
      f_src f_tgt r_ctx os ot
      ths im_src im_tgt st_src st_tgt
      ktr_src itr_tgt
    :
    _genos tid genos RR f_src f_tgt r_ctx (os, trigger (Undefined) >>= ktr_src) (ot, itr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
  | genos_fairL
      f_src f_tgt r_ctx os ot
      ths im_src0 im_tgt st_src st_tgt
      f ktr_src itr_tgt
      (GENOS: exists im_src1,
          (<<FAIR: fair_update im_src0 im_src1 f>>) /\
            (<<GENOS: genos _ _ RR true f_tgt r_ctx (os, ktr_src tt) (ot, itr_tgt) (ths, im_src1, im_tgt, st_src, st_tgt)>>))
    :
    _genos tid genos RR f_src f_tgt r_ctx (os, trigger (Fair f) >>= ktr_src) (ot, itr_tgt) (ths, im_src0, im_tgt, st_src, st_tgt)

  | genos_tauR
      f_src f_tgt r_ctx os ot
      ths im_src im_tgt st_src st_tgt
      itr_src itr_tgt
      (GENOS: genos _ _ RR f_src true r_ctx (os, itr_src) (ot, itr_tgt) (ths, im_src, im_tgt, st_src, st_tgt))
    :
    _genos tid genos RR f_src f_tgt r_ctx (os, itr_src) (ot, Tau itr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
  | genos_chooseR
      f_src f_tgt r_ctx os ot
      ths im_src im_tgt st_src st_tgt
      X itr_src ktr_tgt
      (GENOS: forall x, genos _ _ RR f_src true r_ctx (os, itr_src) (ot, ktr_tgt x) (ths, im_src, im_tgt, st_src, st_tgt))
    :
    _genos tid genos RR f_src f_tgt r_ctx (os, itr_src) (ot, trigger (Choose X) >>= ktr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
  | genos_rmwR
      f_src f_tgt r_ctx os ot
      ths im_src im_tgt st_src st_tgt
      X rmw itr_src ktr_tgt
      (GENOS: genos _ _ RR f_src true r_ctx (os, itr_src) (ot, ktr_tgt (snd (rmw st_tgt) : X)) (ths, im_src, im_tgt, st_src, fst (rmw st_tgt)))
    :
    _genos tid genos RR f_src f_tgt r_ctx (os, itr_src) (ot, trigger (Rmw rmw) >>= ktr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
  | genos_tidR
      f_src f_tgt r_ctx os ot
      ths im_src im_tgt st_src st_tgt
      itr_src ktr_tgt
      (GENOS: genos _ _ RR f_src true r_ctx (os, itr_src) (ot, ktr_tgt tid) (ths, im_src, im_tgt, st_src, st_tgt))
    :
    _genos tid genos RR f_src f_tgt r_ctx (os, itr_src) (ot, trigger (GetTid) >>= ktr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
  | genos_fairR
      f_src f_tgt r_ctx os ot
      ths im_src im_tgt0 st_src st_tgt
      f itr_src ktr_tgt
      (GENOS: forall im_tgt1 (FAIR: fair_update im_tgt0 im_tgt1 (prism_fmap inrp f)),
          (<<GENOS: genos _ _ RR f_src true r_ctx (os, itr_src) (ot, ktr_tgt tt) (ths, im_src, im_tgt1, st_src, st_tgt)>>))
    :
    _genos tid genos RR f_src f_tgt r_ctx (os, itr_src) (ot, trigger (Fair f) >>= ktr_tgt) (ths, im_src, im_tgt0, st_src, st_tgt)

  | genos_observe
      f_src f_tgt r_ctx os ot
      ths im_src im_tgt st_src st_tgt
      fn args ktr_src ktr_tgt
      (GENOS: forall ret,
          genos _ _ RR true true r_ctx (os, ktr_src ret) (ot, ktr_tgt ret) (ths, im_src, im_tgt, st_src, st_tgt))
    :
    _genos tid genos RR f_src f_tgt r_ctx (os, trigger (Observe fn args) >>= ktr_src) (ot, trigger (Observe fn args) >>= ktr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)

  | genos_call
      f_src f_tgt r_ctx os ot
      ths im_src im_tgt st_src st_tgt
      fn args ktr_src itr_tgt
    : _genos tid genos RR f_src f_tgt r_ctx (os, trigger (Call fn args) >>= ktr_src) (ot, itr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)

  | genos_yieldL
      f_src f_tgt r_ctx os ot
      ths im_src im_tgt st_src st_tgt
      ktr_src itr_tgt
      (GENOS: exists os1 ot1,
          (<<GENOS: genos _ _ RR true f_tgt r_ctx (os1, ktr_src tt) (ot1, trigger (Yield) >>= itr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)>>) /\
            (<<LT: (wf_stt R0 R1).(lt) os1 os>>))
    :
    _genos tid genos RR f_src f_tgt r_ctx (os, trigger (Yield) >>= ktr_src) (ot, trigger (Yield) >>= itr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
  | genos_yieldR
      f_src f_tgt r_ctx0 os ot
      ths0 im_src0 im_tgt0 st_src0 st_tgt0
      r_own r_shared
      ktr_src ktr_tgt
      (INV: I (ths0, im_src0, im_tgt0, st_src0, st_tgt0) r_shared)
      (VALID: URA.wf (r_shared ⋅ r_own ⋅ r_ctx0))
      (GENOS: forall ths1 im_src1 im_tgt1 st_src1 st_tgt1 r_shared1 r_ctx1
               (INV: I (ths1, im_src1, im_tgt1, st_src1, st_tgt1) r_shared1)
               (VALID: URA.wf (r_shared1 ⋅ r_own ⋅ r_ctx1))
               im_tgt2
               (TGT: fair_update im_tgt1 im_tgt2 (prism_fmap inlp (tids_fmap tid ths1))),
        exists os1 ot1,
          (<<GENOS: genos _ _ RR f_src true r_ctx1 (os1, trigger (Yield) >>= ktr_src) (ot1, ktr_tgt tt) (ths1, im_src1, im_tgt2, st_src1, st_tgt1)>>) /\
            (<<LT: (wf_stt R0 R1).(lt) ot1 ot>>))
    :
    _genos tid genos RR f_src f_tgt r_ctx0 (os, trigger (Yield) >>= ktr_src) (ot, trigger (Yield) >>= ktr_tgt) (ths0, im_src0, im_tgt0, st_src0, st_tgt0)
  | genos_sync
      f_src f_tgt r_ctx0 os ot
      ths0 im_src0 im_tgt0 st_src0 st_tgt0
      r_own r_shared
      ktr_src ktr_tgt
      (INV: I (ths0, im_src0, im_tgt0, st_src0, st_tgt0) r_shared)
      (VALID: URA.wf (r_shared ⋅ r_own ⋅ r_ctx0))
      (GENOS: forall ths1 im_src1 im_tgt1 st_src1 st_tgt1 r_shared1 r_ctx1
               (INV: I (ths1, im_src1, im_tgt1, st_src1, st_tgt1) r_shared1)
               (VALID: URA.wf (r_shared1 ⋅ r_own ⋅ r_ctx1))
               im_tgt2
               (TGT: fair_update im_tgt1 im_tgt2 (prism_fmap inlp (tids_fmap tid ths1))),
        exists os1 ot1,
          (<<GENOS: genos _ _ RR true true r_ctx1 (os1, ktr_src tt) (ot1, ktr_tgt tt) (ths1, im_src1, im_tgt2, st_src1, st_tgt1)>>))
    :
    _genos tid genos RR f_src f_tgt r_ctx0 (os, trigger (Yield) >>= ktr_src) (ot, trigger (Yield) >>= ktr_tgt) (ths0, im_src0, im_tgt0, st_src0, st_tgt0)

  | genos_progress
      r_ctx os ot
      ths im_src im_tgt st_src st_tgt
      itr_src itr_tgt
      (GENOS: lsim I tid RR false false r_ctx (itr_src) (itr_tgt) (ths, im_src, im_tgt, st_src, st_tgt))
    :
    _genos tid genos RR true true r_ctx (os, itr_src) (ot, itr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
  .

  Definition genos (tid: thread_id)
             R0 R1 (RR: R0 -> R1 -> URA.car -> shared_rel):
    bool -> bool -> URA.car -> ((wf_stt R0 R1).(T) * itree srcE R0) -> ((wf_stt R0 R1).(T) * itree tgtE R1) -> shared_rel :=
    pind9 (_genos tid) top9 R0 R1 RR.

  Lemma genos_mon tid: monotone9 (_genos tid).
  Proof.
    ii. inv IN; try (econs; eauto; fail).
    { des. econs; eauto. }
    { des. econs; eauto. }
    { econs. i. eapply LE. eapply GENOS. eauto. }
    { des. econs; eauto. esplits; eauto. }
    { eapply genos_yieldR; eauto. i. hexploit GENOS; eauto. i. des. esplits; eauto. }
    { eapply genos_sync; eauto. i. hexploit GENOS; eauto. i. des. esplits; eauto. }
  Qed.

  Local Hint Constructors _genos: core.
  Local Hint Unfold genos: core.
  Local Hint Resolve genos_mon: paco.

  Lemma genos_ord_weakL
        tid R0 R1 (LRR: R0 -> R1 -> URA.car -> shared_rel)
        ps pt r_ctx src tgt (shr: shared)
        os0 os1
        (LT: (wf_stt R0 R1).(lt) os0 os1)
        (GENOS: genos tid LRR ps pt r_ctx (os0, src) tgt shr)
    :
    genos tid LRR ps pt r_ctx (os1, src) tgt shr.
  Proof.
    remember (os0, src) as osrc.
    move GENOS before tid. revert_until GENOS.
    pattern R0, R1, LRR, ps, pt, r_ctx, osrc, tgt, shr.
    revert R0 R1 LRR ps pt r_ctx osrc tgt shr GENOS. apply pind9_acc.
    intros rr DEC IH. clear DEC. intros R0 R1 LRR ps pt r_ctx osrc tgt shr GENOS.
    i; clarify.
    eapply pind9_unfold in GENOS; eauto with paco.
    inv GENOS.

    { eapply pind9_fold. eapply genos_ret; eauto. }
    { eapply pind9_fold. eapply genos_tauL; eauto.
      destruct GENOS0 as [GENOS IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind9_fold. eapply genos_chooseL; eauto.
      des. destruct GENOS0 as [GENOS IND]. eapply IH in IND; eauto. esplits; eauto.
      split; ss; eauto.
    }
    { eapply pind9_fold. eapply genos_rmwL; eauto.
      destruct GENOS0 as [GENOS IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind9_fold. eapply genos_tidL; eauto.
      destruct GENOS0 as [GENOS IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind9_fold. eapply genos_UB; eauto. }
    { eapply pind9_fold. eapply genos_fairL; eauto.
      des. destruct GENOS as [GENOS IND]. eapply IH in IND; eauto. esplits; eauto.
      split; ss; eauto.
    }

    { eapply pind9_fold. eapply genos_tauR; eauto.
      destruct GENOS0 as [GENOS IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind9_fold. eapply genos_chooseR; eauto.
      i. specialize (GENOS0 x).
      destruct GENOS0 as [GENOS IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind9_fold. eapply genos_rmwR; eauto.
      destruct GENOS0 as [GENOS IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind9_fold. eapply genos_tidR; eauto.
      destruct GENOS0 as [GENOS IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind9_fold. eapply genos_fairR; eauto.
      i. specialize (GENOS0 _ FAIR).
      destruct GENOS0 as [GENOS IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind9_fold. eapply genos_observe; eauto.
      i. specialize (GENOS0 ret).
      destruct GENOS0 as [GENOS IND]. eapply IH in IND; eauto. split; ss.
    }

    { eapply pind9_fold. eapply genos_call; eauto. }

    { eapply pind9_fold. eapply genos_yieldL; eauto.
      des. destruct GENOS as [GENOS IND]. eapply IH in IND; eauto.
      esplits. split; ss. eapply IND. auto.
    }

    { eapply pind9_fold. eapply genos_yieldR; eauto.
      i. specialize (GENOS0 _ _ _ _ _ _ _ INV0 VALID0 _ TGT). des. esplits; eauto.
      eapply upind9_mon; eauto. ss.
    }

    { eapply pind9_fold. eapply genos_sync; eauto.
      i. specialize (GENOS0 _ _ _ _ _ _ _ INV0 VALID0 _ TGT). des. esplits; eauto.
      eapply upind9_mon; eauto. ss.
    }

    { eapply pind9_fold. eapply genos_progress; eauto. }

  Qed.

  Lemma genos_ord_weakR
        tid R0 R1 (LRR: R0 -> R1 -> URA.car -> shared_rel)
        ps pt r_ctx src tgt (shr: shared)
        ot0 ot1
        (LT: (wf_stt R0 R1).(lt) ot0 ot1)
        (GENOS: genos tid LRR ps pt r_ctx src (ot0, tgt) shr)
    :
    genos tid LRR ps pt r_ctx src (ot1, tgt) shr.
  Proof.
    remember (ot0, tgt) as otgt.
    move GENOS before tid. revert_until GENOS.
    pattern R0, R1, LRR, ps, pt, r_ctx, src, otgt, shr.
    revert R0 R1 LRR ps pt r_ctx src otgt shr GENOS. apply pind9_acc.
    intros rr DEC IH. clear DEC. intros R0 R1 LRR ps pt r_ctx src otgt shr GENOS.
    i; clarify.
    eapply pind9_unfold in GENOS; eauto with paco.
    inv GENOS.

    { eapply pind9_fold. eapply genos_ret; eauto. }
    { eapply pind9_fold. eapply genos_tauL; eauto.
      destruct GENOS0 as [GENOS IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind9_fold. eapply genos_chooseL; eauto.
      des. destruct GENOS0 as [GENOS IND]. eapply IH in IND; eauto. esplits; eauto.
      split; ss; eauto.
    }
    { eapply pind9_fold. eapply genos_rmwL; eauto.
      destruct GENOS0 as [GENOS IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind9_fold. eapply genos_tidL; eauto.
      destruct GENOS0 as [GENOS IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind9_fold. eapply genos_UB; eauto. }
    { eapply pind9_fold. eapply genos_fairL; eauto.
      des. destruct GENOS as [GENOS IND]. eapply IH in IND; eauto. esplits; eauto.
      split; ss; eauto.
    }

    { eapply pind9_fold. eapply genos_tauR; eauto.
      destruct GENOS0 as [GENOS IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind9_fold. eapply genos_chooseR; eauto.
      i. specialize (GENOS0 x).
      destruct GENOS0 as [GENOS IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind9_fold. eapply genos_rmwR; eauto.
      destruct GENOS0 as [GENOS IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind9_fold. eapply genos_tidR; eauto.
      destruct GENOS0 as [GENOS IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind9_fold. eapply genos_fairR; eauto.
      i. specialize (GENOS0 _ FAIR).
      destruct GENOS0 as [GENOS IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind9_fold. eapply genos_observe; eauto.
      i. specialize (GENOS0 ret).
      destruct GENOS0 as [GENOS IND]. eapply IH in IND; eauto. split; ss.
    }

    { eapply pind9_fold. eapply genos_call; eauto. }

    { eapply pind9_fold. eapply genos_yieldL; eauto.
      des. esplits; eauto.
      eapply upind9_mon; eauto. ss.
    }

    { eapply pind9_fold. eapply genos_yieldR; eauto.
      i. specialize (GENOS0 _ _ _ _ _ _ _ INV0 VALID0 _ TGT). des.
      destruct GENOS as [GENOS IND]. eapply IH in IND; eauto.
      esplits; eauto. split; ss. eauto.
    }

    { eapply pind9_fold. eapply genos_sync; eauto.
      i. specialize (GENOS0 _ _ _ _ _ _ _ INV0 VALID0 _ TGT). des. esplits; eauto.
      eapply upind9_mon; eauto. ss.
    }

    { eapply pind9_fold. eapply genos_progress; eauto. }

  Qed.

  Lemma gensim_genos
        tid R0 R1 (RR: R0 -> R1 -> URA.car -> shared_rel)
        ps pt r_ctx src tgt shr
        (LSIM: lsim I tid RR ps pt r_ctx src tgt shr)
    :
    exists os ot, genos tid RR ps pt r_ctx (os, src) (ot, tgt) shr.
  Proof.
    punfold LSIM.
    pattern R0, R1, RR, ps, pt, r_ctx, src, tgt, shr.
    revert R0 R1 RR ps pt r_ctx src tgt shr LSIM. apply pind9_acc.
    intros rr DEC IH. clear DEC. intros R0 R1 RR ps pt r_ctx src tgt shr LSIM.
    eapply pind9_unfold in LSIM; eauto with paco.
    set (zero:= @ord_tree_base (A R0 R1)). set (fzero:= fun _: (A R0 R1) => zero). set (one:= ord_tree_cons fzero).
    inv LSIM.

    { exists zero, zero. eapply pind9_fold. eapply genos_ret; eauto. }

    { destruct LSIM0 as [LSIM IND]. eapply IH in IND. des.
      exists os, ot. eapply pind9_fold. eapply genos_tauL; eauto. split; ss.
    }
    { des. destruct LSIM0 as [LSIM IND]. eapply IH in IND. des.
      exists os, ot. eapply pind9_fold. eapply genos_chooseL; eauto. eexists. split; ss. eauto.
    }
    { destruct LSIM0 as [LSIM IND]. eapply IH in IND. des.
      exists os, ot. eapply pind9_fold. eapply genos_rmwL; eauto. split; ss.
    }
    { destruct LSIM0 as [LSIM IND]. eapply IH in IND. des.
      exists os, ot. eapply pind9_fold. eapply genos_tidL; auto. split; ss.
    }
    { exists zero, zero. eapply pind9_fold. eapply genos_UB; eauto. }
    { des. destruct LSIM as [LSIM IND]. eapply IH in IND. des.
      exists os, ot. eapply pind9_fold. eapply genos_fairL; eauto. esplits; eauto. split; ss.
    }

    { destruct LSIM0 as [LSIM IND]. eapply IH in IND. des. exists os, ot.
      eapply pind9_fold. eapply genos_tauR; eauto. ss.
    }

    { hexploit ord_tree_join.
      { instantiate (2:=A R0 R1).
        instantiate (2:= fun '(ps, pt, rs, src, tgt, shr) => @rr R0 R1 RR ps pt rs src tgt shr).
        i. ss. des_ifs. eapply IH in SAT.
        instantiate (1:= fun '(ps, pt, rs, src, tgt, shr) o =>
                           exists ot, genos tid RR ps pt rs (o, src) (ot, tgt) shr).
        eauto.
      }
      intro JOIN1. des. exists o1.
      hexploit ord_tree_join.
      { instantiate (2:=A R0 R1).
        instantiate (2:= fun '(ps, pt, rs, src, tgt, shr) => @rr R0 R1 RR ps pt rs src tgt shr).
        i. ss. des_ifs.
        specialize (JOIN1 (b, b0, c, i0, i, s)). destruct JOIN1; auto. des.
        instantiate (1:= fun '(ps, pt, rs, src, tgt, shr) o =>
                           genos tid RR ps pt rs (o1, src) (o, tgt) shr).
        exists ot. eapply genos_ord_weakL; eauto.
      }
      intro JOIN2. des. exists o0.
      eapply pind9_fold. eapply genos_chooseR.
      i. specialize (LSIM0 x). destruct LSIM0 as [LSIM IND].
      specialize (JOIN1 (ps, true, r_ctx, src, (ktr_tgt x), (ths, im_src, im_tgt, st_src, st_tgt))).
      destruct JOIN1; auto. des.
      specialize (JOIN2 (ps, true, r_ctx, src, (ktr_tgt x), (ths, im_src, im_tgt, st_src, st_tgt))).
      destruct JOIN2; auto. des.
      split; ss.
      eapply genos_ord_weakR; eauto.
    }

    { destruct LSIM0 as [LSIM IND]. eapply IH in IND. des. exists os, ot.
      eapply pind9_fold. eapply genos_rmwR; eauto. ss.
    }
    { destruct LSIM0 as [LSIM IND]. eapply IH in IND. des. exists os, ot.
      eapply pind9_fold. eapply genos_tidR; eauto. ss.
    }

    { hexploit ord_tree_join.
      { instantiate (2:=A R0 R1).
        instantiate (2:= fun '(ps, pt, rs, src, tgt, shr) => @rr R0 R1 RR ps pt rs src tgt shr).
        i. ss. des_ifs. eapply IH in SAT.
        instantiate (1:= fun '(ps, pt, rs, src, tgt, shr) o =>
                           exists ot, genos tid RR ps pt rs (o, src) (ot, tgt) shr).
        eauto.
      }
      intro JOIN1. des. exists o1.
      hexploit ord_tree_join.
      { instantiate (2:=A R0 R1).
        instantiate (2:= fun '(ps, pt, rs, src, tgt, shr) => @rr R0 R1 RR ps pt rs src tgt shr).
        i. ss. des_ifs.
        specialize (JOIN1 (b, b0, c, i0, i, s)). destruct JOIN1; auto. des.
        instantiate (1:= fun '(ps, pt, rs, src, tgt, shr) o =>
                           genos tid RR ps pt rs (o1, src) (o, tgt) shr).
        exists ot. eapply genos_ord_weakL; eauto.
      }
      intro JOIN2. des. exists o0.
      eapply pind9_fold. eapply genos_fairR.
      i. specialize (LSIM0 _ FAIR). destruct LSIM0 as [LSIM IND].
      specialize (JOIN1 (ps, true, r_ctx, src, (ktr_tgt tt), (ths, im_src, im_tgt1, st_src, st_tgt))).
      destruct JOIN1; auto. des.
      specialize (JOIN2 (ps, true, r_ctx, src, (ktr_tgt tt), (ths, im_src, im_tgt1, st_src, st_tgt))).
      destruct JOIN2; auto. des.
      split; ss.
      eapply genos_ord_weakR; eauto.
    }

    { hexploit ord_tree_join.
      { instantiate (2:=A R0 R1).
        instantiate (2:= fun '(ps, pt, rs, src, tgt, shr) => @rr R0 R1 RR ps pt rs src tgt shr).
        i. ss. des_ifs. eapply IH in SAT.
        instantiate (1:= fun '(ps, pt, rs, src, tgt, shr) o =>
                           exists ot, genos tid RR ps pt rs (o, src) (ot, tgt) shr).
        eauto.
      }
      intro JOIN1. des. exists o1.
      hexploit ord_tree_join.
      { instantiate (2:=A R0 R1).
        instantiate (2:= fun '(ps, pt, rs, src, tgt, shr) => @rr R0 R1 RR ps pt rs src tgt shr).
        i. ss. des_ifs.
        specialize (JOIN1 (b, b0, c, i0, i, s)). destruct JOIN1; auto. des.
        instantiate (1:= fun '(ps, pt, rs, src, tgt, shr) o =>
                           genos tid RR ps pt rs (o1, src) (o, tgt) shr).
        exists ot. eapply genos_ord_weakL; eauto.
      }
      intro JOIN2. des. exists o0.
      eapply pind9_fold. eapply genos_observe.
      i. specialize (LSIM0 ret). destruct LSIM0 as [LSIM IND].
      specialize (JOIN1 (true, true, r_ctx, (ktr_src ret), (ktr_tgt ret), (ths, im_src, im_tgt, st_src, st_tgt))).
      destruct JOIN1; auto. des.
      specialize (JOIN2 (true, true, r_ctx, (ktr_src ret), (ktr_tgt ret), (ths, im_src, im_tgt, st_src, st_tgt))).
      destruct JOIN2; auto. des.
      split; ss.
      eapply genos_ord_weakR; eauto.
    }

    { hexploit ord_tree_join.
      { instantiate (2:=A R0 R1).
        instantiate (2:= fun '(ps, pt, rs, src, tgt, shr) => @rr R0 R1 RR ps pt rs src tgt shr).
        i. ss. des_ifs. eapply IH in SAT.
        instantiate (1:= fun '(ps, pt, rs, src, tgt, shr) o =>
                           exists ot, genos tid RR ps pt rs (o, src) (ot, tgt) shr).
        eauto.
      }
      intro JOIN1. des. exists o1.
      hexploit ord_tree_join.
      { instantiate (2:=A R0 R1).
        instantiate (2:= fun '(ps, pt, rs, src, tgt, shr) => @rr R0 R1 RR ps pt rs src tgt shr).
        i. ss. des_ifs.
        specialize (JOIN1 (b, b0, c, i0, i, s)). destruct JOIN1; auto. des.
        instantiate (1:= fun '(ps, pt, rs, src, tgt, shr) o =>
                           genos tid RR ps pt rs (o1, src) (o, tgt) shr).
        exists ot. eapply genos_ord_weakL; eauto.
      }
      intro JOIN2. des. exists o0.
      eapply pind9_fold. eapply genos_call.
    }

    { destruct LSIM0 as [LSIM IND]. eapply IH in IND. des.
      set (fos:= fun _: (A R0 R1) => os). exists (ord_tree_cons fos), ot.
      eapply pind9_fold. eapply genos_yieldL; eauto. esplits; eauto.
      split; ss. eauto. ss.
      replace os with (fos (true, pt, r_ctx, (ktr_src tt), (x <- trigger Yield;; itr_tgt x), (ths, im_src, im_tgt, st_src, st_tgt))); ss.
    }

    { hexploit ord_tree_join.
      { instantiate (2:=A R0 R1).
        instantiate (2:= fun '(ps, pt, rs, src, tgt, shr) => @rr R0 R1 RR ps pt rs src tgt shr).
        i. ss. des_ifs. eapply IH in SAT.
        instantiate (1:= fun '(ps, pt, rs, src, tgt, shr) o =>
                           exists ot, genos tid RR ps pt rs (o, src) (ot, tgt) shr).
        eauto.
      }
      intro JOIN1. des. exists o1.
      hexploit ord_tree_join.
      { instantiate (2:=A R0 R1).
        instantiate (2:= fun '(ps, pt, rs, src, tgt, shr) => @rr R0 R1 RR ps pt rs src tgt shr).
        i. ss. des_ifs.
        specialize (JOIN1 (b, b0, c, i0, i, s)). destruct JOIN1; auto. des.
        instantiate (1:= fun '(ps, pt, rs, src, tgt, shr) o =>
                           genos tid RR ps pt rs (o1, src) (o, tgt) shr).
        exists ot. eapply genos_ord_weakL; eauto.
      }
      intro JOIN2. des. exists o0.
      eapply pind9_fold. eapply genos_yieldR. 1,2: eauto.
      i. specialize (LSIM0 _ _ _ _ _ _ _ INV0 VALID0 _ TGT). destruct LSIM0 as [LSIM IND].
      specialize (JOIN1 (ps, true, r_ctx1, (x <- trigger Yield;; ktr_src x), ktr_tgt tt, (ths1, im_src1, im_tgt2, st_src1, st_tgt1))).
      destruct JOIN1; auto. des.
      specialize (JOIN2 (ps, true, r_ctx1, (x <- trigger Yield;; ktr_src x), ktr_tgt tt, (ths1, im_src1, im_tgt2, st_src1, st_tgt1))).
      destruct JOIN2; auto. des.
      exists o1, x0. esplits; eauto.
      split; ss.
    }

    { exists zero, zero. eapply pind9_fold. eapply genos_sync; eauto.
      i. specialize (LSIM0 _ _ _ _ _ _ _ INV0 VALID0 _ TGT). destruct LSIM0 as [LSIM IND].
      eapply IH in IND. des. do 2 eexists. split; ss. eapply IND.
    }

    { exists zero, zero. eapply pind9_fold. eapply genos_progress. pclearbot. auto. }

  Qed.

End GENORDER.
#[export] Hint Constructors _genos: core.
#[export] Hint Unfold genos: core.
#[export] Hint Resolve genos_mon: paco.


(* These always worked. *)
Goal prod True True. firstorder. Qed.
Goal True -> @sigT True (fun _ => True). firstorder. Qed.
Goal prod True True. dtauto. Qed.
Goal prod True True. tauto. Qed.

(* These should work. *)
Goal @sigT True (fun _ => True). dtauto. Qed.
(* These should work, but don't *)
(* Goal @sigT True (fun _ => True). firstorder. Qed. *)
(* Goal @sigT True (fun _ => True). tauto. Qed. *)