From iris Require Import program_logic.weakestpre.
From iris.proofmode Require Import tactics.
From st.STLCmuVS Require Import lang virt_steps wkpre generic.lift tactics lib.omega tactics reducibility.
From st.STLCmu Require Import types.
From st.backtranslations.un_syn Require Import logrel.definitions expressions universe.base universe.paths.

Section syn_le_un.

  Instance rfn : refinement := syn_le_un.

  Context `{Σ : !gFunctors}.
  Context `{irisGS_inst : !irisGS STLCmuVS_lang Σ}.

  Lemma wp_Ω Φ : ⊢ WP Ω ?{{Φ}}.
  Proof. iLöb as "IH". iApply wp_nsteps_later. by apply Ω_loop. done. Qed.

  Hint Extern 5 (IntoVal _ _) => eapply of_to_val; fast_done : typeclass_instances.
  Hint Extern 10 (IntoVal _ _) =>
    rewrite /IntoVal; eapply of_to_val; rewrite /= !to_of_val /=; solve [ eauto ] : typeclass_instances.

  Lemma bind_lift_extract (K K' : ectx STLCmuVS_ectx_lang) (e e' : expr) (tc : type_constructor) Φ :
      exprel e e' ∗ (▷ ∀ v v', canon_tc_lift tc valrel v v' -∗ lift? Φ (fill K (of_val v)) (fill K' (of_val v'))) ⊢
        lift? Φ (fill K (extract tc e)) (fill K' e').
  Proof.
    iIntros "[Hee' H]". iApply (lift_bind _ _ _ (AppRCtx _ :: K) K'). iFrame "Hee'".
    iIntros (v u') "#Hvu'". simpl.
    iApply (wp_bind (fill K)). iApply wp_step_later. apply head_prim_step. auto_head_step. iModIntro. asimpl.
    rewrite (valrel_unfold v u').
    iDestruct "Hvu'" as (tc2) "des". iDestruct "des" as (v') "[-> Hvv']".
    rewrite CaseTC_subst. asimpl.
    destruct (decide (tc = tc2)) as [<- | neq] eqn:eq.
    + iApply wp_rtc_steps. apply eval_same_tc.
      iApply wp_value. iApply (wp_wand with "[H]"). iApply "H". auto.
      iIntros (v) "H". auto.
    + iApply wp_rtc_steps. by apply eval_diff_tc.
      iApply wp_Ω.
  Qed.

  Context (n : nat).

  Lemma compat_Var:
    ∀ x : nat, x < n → open_exprel n (%x)%Eₙₒ (%x)%Eₙₒ.
  Proof.
    intros x H. iIntros (vs vs' Hlvs) "#Hvv's".
    destruct (Var_subst_list_closed_n_length vs x) as [v [eqv ->]]. apply ids_lt_Closed_n. by rewrite Hlvs.
    iDestruct (big_sepL2_length with "Hvv's") as %Hl.
    destruct (Var_subst_list_closed_n_length vs' x) as [v' [eqv' ->]]. apply ids_lt_Closed_n. by rewrite -Hl Hlvs.
    rewrite /exprel /=. iApply lift_val.
    iApply ((big_sepL2_lookup _ vs vs' x _ _ eqv eqv') with "Hvv's").
  Qed.

  Lemma compat_LetIn :
    ∀ e1 e1' e2 e2' : expr, open_exprel n e1 e1' → open_exprel (S n) e2 e2' →
                                            open_exprel n (LetIn e1 e2) (LetIn e1' e2').
  Proof.
    intros e1 e1' e2 e2' IH1 IH2.
    iIntros (vs vs' Hlvs) "#Hvv's". asimpl.
    iApply (lift_bind _ _ _ [LetInCtx _] [LetInCtx _]). iSplitL "". iApply IH1; auto.
    iIntros (u v') "Huv'/=". iApply lift_step_later. asimpl. auto_STLCmuVS_step. iApply lift_step. auto_STLCmuVS_step. iNext. simplify_custom. asimpl. do 2 rewrite subst_list_val_cons.
    iApply IH2; auto. simpl. auto.
  Qed.

  Lemma compat_Lam:
    ∀ e e' : expr,
      open_exprel (S n) e e'
      → open_exprel n (inject TCArrow (Lam e)) (Lam e').
  Proof.
    intros e e' IHe.
    iIntros (vs vs' Hlvs) "#Hvv's". asimpl.
    rewrite /= inject_Closed.
    iApply lift_step_later. eapply (inject_step _ _ (LamV _)). auto. iNext.
    change (Lam ?e) with (of_val $ LamV e). iApply lift_val.
    rewrite valrel_unfold. iExists TCArrow. fold valrel. iExists (LamV e.[up (subst_list_val vs)]). iSplit; auto.
    simpl. iExists _. iSplit. auto.
    do 2 iModIntro. iIntros (w w') "#Hww'".
    iApply lift_step. auto_STLCmuVS_step. simplify_custom.
    asimpl. do 2 rewrite subst_list_val_cons.
    iApply IHe. simpl. lia. simpl. auto.
  Qed.

  Lemma compat_App:
    ∀ e1 e1' e2 e2' : expr,
      open_exprel n e1 e1'
      → open_exprel n e2 e2'
      → open_exprel n (extract TCArrow e1 e2) (e1' e2').
  Proof.
    intros e1 e1' e2 e2' IHe1 IHe2.
    iIntros (vs vs' Hlvs) "#Hvv's". asimpl.
    asimpl. rewrite extract_Closed.
    iApply (bind_lift_extract [AppLCtx _] [AppLCtx _]).
    iSplitL "". iApply IHe1; auto. iNext.
    iIntros (v v') "des". simpl. iDestruct "des" as (e) "(-> & #H)".
    iApply (lift_bind _ _ _ [AppRCtx _] [AppRCtx _]). iSplitL "". iApply IHe2; auto.
    iIntros (w w') "Hww'". simpl. iApply lift_step_later. auto_STLCmuVS_step.
    simplify_custom. iNext. iApply ("H" with "Hww'").
  Qed.

  Lemma compat_Lit:
    ∀ l : base_lit,
      open_exprel n
                  match l with
                  | LitInt n0 => inject TCInt n0
                  | LitBool b => inject TCBool b
                  | LitUnit => inject TCUnit ()%Eₙₒ
                  end l.
  Proof.
    intros l.
    iIntros (vs vs' Hlvs) "#Hvv's". asimpl.
    rewrite /=; destruct l; asimpl; rewrite inject_Closed.
    + iApply lift_step_later. eapply (inject_step _ _ n0); auto. change (Lit n0) with (of_val n0). iApply lift_val.
      rewrite valrel_unfold. iExists TCInt. iExists _. iSplit; auto. simpl. iExists n0 ; (iSplit; eauto).
    + iApply lift_step_later. eapply (inject_step _ _ b); auto. change (Lit b) with (of_val b). iApply lift_val.
      rewrite valrel_unfold. iExists TCBool. iExists _; iSplit; auto. simpl. iExists _ ; (iSplit; eauto).
    + iApply lift_step_later. eapply (inject_step _ _ ()%Vₙₒ); auto. change ()%Eₙₒ with (of_val ()%Vₙₒ). iApply lift_val.
      rewrite valrel_unfold. iExists TCUnit. iExists _; iSplit; auto.
  Qed.

  Lemma compat_BinOp:
    ∀ (op : bin_op) (e1 e1' e2 e2' : expr),
      open_exprel n e1 e1'
      → open_exprel n e2 e2'
      → open_exprel n
                    (inject match op with
                            | PlusOp | MinusOp => TCInt
                            | _ => TCBool
                            end
                            (BinOp op (extract TCInt e1) (extract TCInt e2)))
                    (BinOp op e1' e2').
  Proof.
    intros op e1 e1' e2 e2' IHe1 IHe2.
    iIntros (vs vs' Hlvs) "#Hvv's". asimpl.
    rewrite /= inject_Closed extract_Closed.
    iApply (lift_bind' _ _ _ [AppRCtx _; BinOpLCtx _ _; AppRCtx _] [BinOpLCtx _ _]). iApply IHe1. auto. auto.
    iIntros (v1 v1') "#Hv1". simpl.
    iApply (bind_lift_extract [BinOpLCtx _ _; AppRCtx _] [BinOpLCtx _ _]). iSplitL. by iApply lift_val. iNext.
    iIntros (w1 w1') "#Hw1". simpl.
    iApply (lift_bind' _ _ _ [AppRCtx _; BinOpRCtx _ _; AppRCtx _] [BinOpRCtx _ _]). iApply IHe2. auto. auto.
    iIntros (v2 v2') "#Hv2". simpl.
    iApply (bind_lift_extract [BinOpRCtx _ _; AppRCtx _] [BinOpRCtx _ _]). iSplitL. by iApply lift_val. iNext.
    iIntros (w2 w2') "#Hw2". simpl.
    iDestruct "Hw1" as (z1) "[-> ->]".
    iDestruct "Hw2" as (z2) "[-> ->]".
    iApply lift_step_later. auto_STLCmuVS_step.
    iApply lift_step. auto_STLCmuVS_step. simplify_custom.
    iApply lift_step_later. apply inject_step'. iApply lift_val. iNext. iNext.
    iEval (rewrite valrel_unfold).
    destruct op; repeat iExists _; eauto.
  Qed.

  Lemma compat_If:
    ∀ e0 e0' e1 e1' e2 e2' : expr,
      open_exprel n e0 e0'
      → open_exprel n e1 e1'
      → open_exprel n e2 e2'
      → open_exprel n (If (extract TCBool e0) e1 e2)
                    (If e0' e1' e2').
  Proof.
    intros e0 e0' e1 e1' e2 e2' IHe1 IHe2 IHe3.
    iIntros (vs vs' Hlvs) "#Hvv's". asimpl.
    rewrite /= extract_Closed.
    iApply (bind_lift_extract [IfCtx _ _] [IfCtx _ _]). iSplitL. iApply IHe1; auto. iNext.
    iIntros (v v') "Hvv". simpl. iDestruct "Hvv" as (b) "[-> ->]".
    destruct b.
    + iApply lift_step_later. auto_STLCmuVS_step. iApply lift_step. auto_STLCmuVS_step. simpl.
      iApply IHe2; auto.
    + iApply lift_step_later. auto_STLCmuVS_step. iApply lift_step. auto_STLCmuVS_step. simpl.
      iApply IHe3; auto.
  Qed.

  Lemma compat_Seq:
    ∀ e1 e1' e2 e2' : expr,
      open_exprel n e1 e1'
      → open_exprel n e2 e2'
      → open_exprel n (Seq (extract TCUnit e1) e2) (Seq e1' e2').
  Proof.
    intros e1 e1' e2 e2' IHe1 IHe2.
    iIntros (vs vs' Hlvs) "#Hvv's". asimpl.
    rewrite /= extract_Closed.
    iApply (bind_lift_extract [SeqCtx _] [SeqCtx _]). iSplitL "". iApply IHe1; auto. iNext. simpl.
    iIntros (v v') "[-> ->]". iApply lift_step_later. auto_STLCmuVS_step. iApply lift_step. auto_STLCmuVS_step. simpl.
    iApply IHe2; auto.
  Qed.

  Lemma compat_Pair:
    ∀ e1 e1' e2 e2' : expr,
      open_exprel n e1 e1'
      → open_exprel n e2 e2'
      → open_exprel n (inject TCProd (e1 , e2)%Eₙₒ) (e1', e2')%Eₙₒ.
  Proof.
    intros e1 e1' e2 e2' IHe1 IHe2.
    iIntros (vs vs' Hlvs) "#Hvv's". asimpl.
    asimpl. rewrite inject_Closed.
    iApply (lift_bind _ _ _ [PairLCtx _; AppRCtx _] [PairLCtx _]). iSplitL "". iApply IHe1; auto. iIntros (u1 v1') "#IHu1v1'". simpl.
    iApply (lift_bind _ _ _ [PairRCtx _; AppRCtx _] [PairRCtx _]). iSplitL "". iApply IHe2; auto. iIntros (u2 v2') "#IHu2v2'". simpl.
    iApply lift_step_later. apply inject_step with (v := PairV u1 u2); eauto.
    change (v1',v2')%Eₙₒ with (of_val (v1',v2')%Vₙₒ). iApply lift_val.
    iEval (rewrite valrel_unfold). iExists TCProd. iExists _. iSplit; auto. iExists _, _, _, _. repeat iSplit; done.
  Qed.

  Lemma compat_Fst:
    ∀ e e' : expr,
      open_exprel n e e'
      → open_exprel n (Fst (extract TCProd e)) (Fst e').
  Proof.
    intros e e' IHe.
    iIntros (vs vs' Hlvs) "#Hvv's". asimpl.
    rewrite /= extract_Closed.
    iApply (bind_lift_extract [FstCtx] [FstCtx]). iSplitL "". iApply IHe; auto.
    iNext. iIntros (v v') "des/=". iDestruct "des" as (v1 v2 v1' v2') "(-> & -> & #H1 & #H2)".
    iApply lift_step_later. auto_STLCmuVS_step. iApply lift_step. auto_STLCmuVS_step. simplify_custom. iApply lift_val. done.
  Qed.

  Lemma compat_Snd:
    ∀ e e' : expr,
      open_exprel n e e'
      → open_exprel n (Snd (extract TCProd e)) (Snd e').
  Proof.
    intros e e' IHe.
    iIntros (vs vs' Hlvs) "#Hvv's". asimpl.
    rewrite /= extract_Closed.
    iApply (bind_lift_extract [SndCtx] [SndCtx]). iSplitL "". iApply IHe; auto.
    iNext. iIntros (v v') "des/=". iDestruct "des" as (v1 v2 v1' v2') "(-> & -> & #H1 & #H2)".
    iApply lift_step_later. auto_STLCmuVS_step. iApply lift_step. auto_STLCmuVS_step. simplify_custom. iApply lift_val. done.
  Qed.

  Lemma compat_InjL:
    ∀ e e' : expr,
      open_exprel n e e'
      → open_exprel n (inject TCSum (InjL e)) (InjL e').
  Proof.
    intros e e' IHe.
    iIntros (vs vs' Hlvs) "#Hvv's". asimpl.
    rewrite /= inject_Closed.
    iApply (lift_bind _ _ _ [InjLCtx; AppRCtx _] [InjLCtx]). iSplitL "". iApply IHe; auto.
    iIntros (v u') "#Hvu'". simpl.
    iApply lift_step_later. apply inject_step with (v := InjLV v). auto. iNext. change (InjL u') with (of_val (InjLV u')).
    iApply lift_val. iEval (rewrite valrel_unfold). iExists TCSum. iExists _. iSplit; auto. iExists _, _. repeat iSplit; auto.
  Qed.

  Lemma compat_InjR:
    ∀ e e' : expr,
      open_exprel n e e'
      → open_exprel n (inject TCSum (InjR e)) (InjR e').
  Proof.
    intros e e' IHe.
    iIntros (vs vs' Hlvs) "#Hvv's". asimpl.
    rewrite /= inject_Closed.
    iApply (lift_bind _ _ _ [InjRCtx; AppRCtx _] [InjRCtx]). iSplitL "". iApply IHe; auto.
    iIntros (v u') "#Hvu'". simpl.
    iApply lift_step_later. apply inject_step with (v := InjRV v). auto. iNext. change (InjR u') with (of_val (InjRV u')).
    iApply lift_val. iEval (rewrite valrel_unfold). iExists TCSum. iExists _. iSplit; auto. iExists _, _. repeat iSplit; auto.
  Qed.

  Lemma compat_Case:
    ∀ e0 e0' e1 e1' e2 e2' : expr,
      open_exprel n e0 e0'
      → open_exprel (S n) e1 e1'
      → open_exprel (S n) e2 e2'
      → open_exprel n (Case (extract TCSum e0) e1 e2)
                    (Case e0' e1' e2').
  Proof.
    intros e0 e0' e1 e1' e2 e2' IHe0 IHe1 IHe2.
    iIntros (vs vs' Hlvs) "#Hvv's". asimpl.
    rewrite /= extract_Closed.
    iApply (bind_lift_extract [CaseCtx _ _] [CaseCtx _ _]). iSplitL "". iApply IHe0; auto.
    iNext. iIntros (v v') "des/=". iDestruct "des" as (vi vi') "[(-> & -> & #Hi)|(-> & -> & #Hi)]".
    + iApply lift_step_later. auto_STLCmuVS_step. iApply lift_step. auto_STLCmuVS_step. simplify_custom. asimpl.
      iNext. do 2 rewrite subst_list_val_cons. iApply IHe1; auto. simpl. auto.
    + iApply lift_step_later. auto_STLCmuVS_step. iApply lift_step. auto_STLCmuVS_step. simplify_custom. asimpl.
      iNext. do 2 rewrite subst_list_val_cons. iApply IHe2; auto. simpl. auto.
  Qed.

  Lemma compat_Fold:
    ∀ e e' : expr,
      open_exprel n e e'
      → open_exprel n (inject TCRec (Fold e)) (Fold e').
  Proof.
    intros e e' IHe.
    iIntros (vs vs' Hlvs) "#Hvv's". asimpl.
    rewrite /= inject_Closed.
    iApply (lift_bind _ _ _ [FoldCtx; AppRCtx _] [FoldCtx]). iSplitL "". iApply IHe; auto.
    iIntros (v u') "#Hvu'". simpl. iApply lift_step_later. apply inject_step with (v := FoldV v); auto. iNext. change (Fold u') with (of_val $ FoldV u').
    iApply lift_val. iEval (rewrite valrel_unfold). iExists TCRec. iExists _. iSplit; auto. iExists _, _. repeat iSplit; auto.
  Qed.

  Lemma compat_Unfold:
    ∀ e e' : expr,
      open_exprel n e e'
      → open_exprel n (Unfold (extract TCRec e)) (Unfold e').
  Proof.
    intros e e' IHe.
    iIntros (vs vs' Hlvs) "#Hvv's". asimpl.
    rewrite /= extract_Closed.
    iApply (bind_lift_extract [UnfoldCtx] [UnfoldCtx]). iSplitL "". iApply IHe; auto.
    iNext. iIntros (v v') "des/=". iDestruct "des" as (w w') "(-> & -> & #H)".
    iApply lift_step_later. auto_STLCmuVS_step. iApply lift_step. auto_STLCmuVS_step. simplify_custom. iApply lift_val. iApply "H".
  Qed.

  Lemma compat_VirtStep_help : ∀ v v',
      valrel v v' ⊢ valrel v (VirtStepped v').
  Proof.
    iLöb as "IHlob".
    iIntros (v v') "#Hvv'".
    iEval (rewrite valrel_unfold) in "Hvv'". fold valrel. iDestruct "Hvv'" as (tc w) "[-> Hcan]".
    destruct tc; iEval (simpl) in "Hcan".
    - iDestruct "Hcan" as "[-> ->]". simpl.
      rewrite valrel_unfold. iExists TCUnit, _. auto.
    - iDestruct "Hcan" as (b) "[-> ->]". simpl.
      rewrite valrel_unfold. iExists TCBool, _. iSplit; auto. by iExists _.
    - iDestruct "Hcan" as (z) "[-> ->]". simpl.
      rewrite valrel_unfold. iExists TCInt, _. iSplit; auto. by iExists _.
    - iDestruct "Hcan" as (v1 v2 v1' v2') "(-> & -> & #H1 & #H2)". simpl.
      iEval (rewrite valrel_unfold). fold valrel. iExists TCProd, _. iSplit; auto.
      iExists _, _, _, _. repeat iSplit; eauto; by iApply "IHlob".
    - iDestruct "Hcan" as (vi vi') "[(-> & -> & #H) | (-> & -> & #H)]/=";
        iEval (rewrite valrel_unfold); fold valrel; iExists TCSum;
          iExists _; iSplit; auto; repeat iExists _.
      + iLeft. repeat iSplit; eauto. by iApply "IHlob".
      + iRight. repeat iSplit; eauto. by iApply "IHlob".
    - iDestruct "Hcan" as (e) "[-> #H]";
        iEval (rewrite valrel_unfold); fold valrel; iExists TCArrow.
      iExists _; iSplit; eauto. simpl. iExists _. iSplit; eauto. iNext.
      iDestruct "H" as "#H". iModIntro.
      iIntros (w w') "Hww'".
      iAssert (valrel w (VirtStepped w')) with "[Hww']" as "Hwws'". by iApply "IHlob".
      iSpecialize ("H" $! w (VirtStepped w') with "Hwws'").
      iApply (wp_wand with "H"). iIntros (v) "Hdes".
      iDestruct "Hdes" as (r) "[%Hsteps #H]".
      iExists (VirtStepped r). iSplit; [|by iApply "IHlob"].
      iPureIntro.
      destruct (dec_expr_reducibility (v' (VirtStepped w'))) as [ vl eq | red | stuck ]; [inversion eq| |].
      * assert (head_reducible (v' (VirtStepped w')) ()).
        { apply prim_head_reducible; auto.
          apply ectxi_language_sub_redexes_are_values.
          intros. destruct Ki; simpl in H; try by inversion H.
          inversion H. subst. eexists _. by rewrite /= to_of_val.
          inversion H. subst. eexists _. by rewrite /= to_of_val. }
        assert (STLCmuVS_head_reducible (v' (VirtStepped w'))). by apply STLCmuVS_prim_head_red.
        destruct H0 as [p hd].
        inversion hd; subst. assert (LamV e1 = v') as <-. by apply of_val_inj.
        eapply rtc_l. auto_STLCmuVS_step. simplify_custom.
        change (Lam e1) with (of_val (LamV e1)).
        eapply rtc_transitive. apply (rtc_STLCmuVS_step_ctx (fill [AppRCtx _; VirtStepCtx])). apply VirtStep_eval. simpl.
        eapply rtc_transitive. by apply (rtc_STLCmuVS_step_ctx (fill [VirtStepCtx])).
        apply VirtStep_eval.
      * exfalso. inversion Hsteps; subst.
        -- assert (abs : to_val (v' (VirtStepped w')) = Some r). by rewrite -to_of_val H1. inversion abs.
        -- destruct stuck. eapply H2. apply H.
    - iDestruct "Hcan" as (x x') "(-> & -> & #H)";
        iEval (rewrite valrel_unfold); fold valrel; iExists TCRec.
      iExists _; eauto. iSplit; eauto. iExists _, _. repeat iSplit; eauto. by iApply "IHlob".
  Qed.

  Lemma compat_VirtStep e e' :
    open_exprel n e e' →
    open_exprel n e (VirtStep e').
  Proof.
    iIntros (IHe vs vs' Hlvs) "#Hvv's". asimpl.
    iApply (lift_bind _ _ _ [] [VirtStepCtx]). iSplitL "". iApply IHe; auto.
    iIntros (v v') "#Hvv'". iClear "Hvv's". simpl.
    iApply lift_rtc_steps. apply VirtStep_eval.
    iApply lift_val. by iApply compat_VirtStep_help.
  Qed.

End syn_le_un.


(** 3. Krivine Abstract Machine *)
Require Import List.

(** 3.2. Krivine code
Code is a list of Access, Grab and Push instructions. This definition merge
instruction and "code = list instruction" definitions, to allow recursion
on Push parameter.
To do this, add "Nop" code, which is equivalent to the nil list.
*)
Inductive krivine_code : Set :=
  | Nop: krivine_code
  | Access: nat -> krivine_code -> krivine_code
  | Grab: krivine_code -> krivine_code
  | Push: krivine_code -> krivine_code -> krivine_code
.

(** Environment stack : (c, e) list *)
Inductive krivine_env : Set :=
  | KEnv_nil: krivine_env
  | KEnv: krivine_code -> krivine_env -> krivine_env -> krivine_env
.

(** a state is (code, env, stack) tuple which may be seen as an environment *)
Definition krivine_state (c: krivine_code) (e s: krivine_env) : krivine_env :=
  KEnv c e s
.

(** Length of an environment list *)
Fixpoint klength (e: krivine_env) : nat :=
  match e with
    | KEnv_nil => O
    | KEnv _ _ e0 => S (klength e0)
  end
.

Lemma klength_O_is_nil:
  forall e: krivine_env, klength e = O -> e = KEnv_nil.
Proof.
  induction e; simpl; intro H; trivial.
  inversion H.
Save.

Lemma klength_nonO_is_not_nil:
  forall e: krivine_env, klength e <> O -> e <> KEnv_nil.
Proof.
  intros e H H0.
  contradict H.
  rewrite H0; trivial.
Save.

Lemma klength_pos_is_not_nil:
  forall e: krivine_env, klength e > O -> e <> KEnv_nil.
Proof.
  intros e H H0.
  contradict H.
  rewrite H0; simpl.
  auto with arith.
Save.

(** 3.3. Semantic: execute one step.
  Return KEnv_nil if there were some error, a krivine_state otherwise.
 *)
Definition krivine_step (st: krivine_env) : krivine_env :=
  match st with
    | KEnv (Access O _) (KEnv c0 e0 _) s => krivine_state c0 e0 s
    | KEnv (Access (S n) c) (KEnv _ _ e) s =>
        krivine_state (Access n c) e s
    | KEnv (Push c0 c) e s => krivine_state c e (KEnv c0 e s)
    | KEnv (Grab c) e (KEnv c0 e0 s) =>
        krivine_state c (KEnv c0 e0 e) s
    (* Final state *)
    | KEnv (Grab c) e KEnv_nil => st
    (* Invalid states *)
    | _ => KEnv_nil
  end
.

(** Execute any number of steps *)
Inductive krivine_step_star: krivine_env -> krivine_env -> Prop :=
  | Krivine_step_star_eq: forall st: krivine_env, krivine_step_star st st
  | Krivine_step_star_step: forall st st': krivine_env,
      krivine_step_star (krivine_step st) st' -> krivine_step_star st st'
.


(*+ Small concurrent stack *)

(** In this file:
- a single-theaded semantics (with oracle and invariants)
- a multi-thread concurrent machine (with schedule and invariants)
- proof that the safety of all threads implies the safety of the machine
- a hoare logic implying safety in the oracle semantics
- a small example yielding safety of the corresponding machine
*)

Require Import List Arith Omega Setoid String.
Require Import Coq.Logic.FunctionalExtensionality.

(* we can remove the need for functional extensionality, at the
   expense of heavier definitions and proofs, with [m |= P] defined as
   [forall m', eqmap m m' -> P m'] instead of [P m] *)

(*+ Syntax *)

Inductive instruction :=
  | set (x e:nat)      (* mem[x] := e *)
  | assert (x:nat)     (* assert mem[x]<>0 *)
  | release (l:nat)    (* unlocking a lock *)
  | acquire (l:nat)    (* locking a lock *)
  | spawn (f:string) (* spawning function f *).

(** spawning could be replaced with

  | spawn (p : list instruction)

and then when reaching it in the oracular semantics, the oracle says
how the current map is split [NO! the oracle would say which map
you're given when you do JOIN, but the safety of the thread has to
provide which map to give away], and then the oracle itself is
(interleaving)-split into two.  We could also write

  | par (p1 p2 : list instruction)

and do the same.  We adopt the spawning with an ID instead because
it's closer to the architecture of VST *)

(*+ General results about safety *)

Definition Rel X := X -> X -> Prop.

Inductive star {X} (R : Rel X) : Rel X :=
  | star_refl x : star R x x
  | star_cons x y z : R x y -> star R y z -> star R x z.

Definition safe {X} (R : Rel X) x := forall y, star R x y -> exists z, R y z.

Lemma safe_R {X} (R : Rel X) x y : safe R x -> R x y -> safe R y.
Proof.
  intros Sx xy z yz.
  destruct (Sx z); eauto.
  econstructor; eauto.
Qed.

Lemma safe_det {X} (R : Rel X) x y : safe R y -> R x y -> (forall y', R x y' -> y = y') -> safe R x.
Proof.
  intros Sy xy D z xz; inversion xz; subst; eauto.
  rewrite <-(D _ H) in *; eauto.
Qed.

Lemma safe_selfloop {X} (R : Rel X) x : R x x -> (forall y, R x y -> y = x) -> safe R x.
Proof.
  intros self loop z xz; induction xz; eauto.
  rewrite (loop _ H) in *; eauto.
Qed.

Lemma safe_one {X} (R : Rel X) x y : R x y -> (forall y, R x y -> safe R y) -> safe R x.
Proof.
  intros xy H z xz.
  inversion xz; subst; compute in *; eauto.
Qed.

(*! Indexed version of safety (not needed here) *)

Inductive iter {X} (R : Rel X) : nat -> Rel X :=
  | iter_O x : iter R O x x
  | iter_S n x y z : R x y -> iter R n y z -> iter R (S n) x z.

Definition safe_ n {X} (R : Rel X) x := forall y m, m < n -> iter R m x y -> exists z, R y z.

Lemma safe_safe_ {X} (R : Rel X) x : safe R x <-> forall n, safe_ n R x.
Proof.
  split.
  - intros Sx n y k kn it; apply Sx.
    clear -it; induction it. constructor.
    econstructor; eauto.
  - intros Sx y st.
    cut (exists n, iter R n x y).
    { intros (n, it). refine (Sx (S n) _ n _ it). auto. }
    clear -st; induction st.
    + exists 0; constructor.
    + destruct IHst as (n, IH); exists (S n); econstructor; eauto.
Qed.

Lemma safe__det {X} (R : Rel X) n x y : safe_ n R y -> R x y -> (forall y', R x y' -> y = y') -> safe_ (S n) R x.
Proof.
  intros Sy xy D z m mn xz; inversion xz; subst; eauto.
  assert (n0 < n) by auto with *.
  rewrite <-(D _ H) in *; eauto.
Qed.

Lemma safe__R {X} (R : Rel X) n x y : safe_ (S n) R x -> R x y -> safe_ n R y.
Proof.
  intros Sx xy z m mn it.
  edestruct (Sx z (S m)); eauto. auto with *.
  econstructor; eauto.
Qed.

Lemma safe_S {X} (R : Rel X) n x : safe_ (S n) R x -> safe_ n R x.
Proof.
  intros S y m mn; apply S; auto.
Qed.

(*+ Stdlib: some list functions *)

Fixpoint nth {A} (l : list A) i :=
  match l with
  | nil => None
  | x :: l =>
    match i with
    | O => Some x
    | S i => nth l i
    end
  end.

Fixpoint nth_upd {A} (l : list A) i x :=
  match l with
  | nil => nil
  | y :: l =>
    match i with
    | O => x :: l
    | S i => y :: nth_upd l i x
    end
  end.

Lemma eq_nat_dec (a b : nat) : {a=b}+{a<>b}. decide equality. Defined.

Ltac ifeq :=
    match goal with
      [ H : context [ eq_nat_dec ?x ?x ] |- _ ] => destruct (eq_nat_dec x x) as [_|]; [|congruence]
    | [ |- context [ eq_nat_dec ?x ?x ] ] => destruct (eq_nat_dec x x) as [_|]; [|congruence]
    | [ H : context [ eq_nat_dec ?x ?y ] |- _ ] => destruct (eq_nat_dec x y)
    | [ |- context [ eq_nat_dec ?x ?y ] ] => destruct (eq_nat_dec x y)
    end.

Lemma nth_nth_upd {A} (l : list A) i x y j :
  nth l i = Some x ->
  nth (nth_upd l i y) j = if eq_nat_dec i j then Some y else nth l j.
Proof.
  revert i j x y; induction l; intros [|i] [|j] x y E; simpl in E; try solve [auto|inversion E].
  unfold nth_upd; fold (@nth_upd A).
  unfold nth; fold (@nth A).
  rewrite (IHl i j x y E).
  ifeq; ifeq; congruence || omega.
Qed.

Lemma nth_upd_app_1 {A} (l1 l2 : list A) i x y :
  nth l1 i = Some x ->
  nth_upd l1 i y ++ l2 = nth_upd (l1 ++ l2) i y.
Proof.
  revert i; induction l1; intros [|i] E; inversion E; auto.
  simpl; f_equal.
  eauto.
Qed.

Lemma nth_app_1 {A} (l1 l2 : list A) i x :
  nth l1 i = Some x ->
  nth (l1 ++ l2) i = Some x.
Proof.
  revert l1; induction i; intros [|y l1] E; simpl; inversion E; auto.
  rewrite IHi; auto.
Qed.

Lemma nth_snoc {A} i (l : list A) x :
  i <> List.length l ->
  nth (l ++ x :: nil) i = nth l i.
Proof.
  revert i; induction l; simpl; intros [|i] D; try congruence.
  apply IHl; auto.
Qed.

Lemma nth_snoc_len {A} (l : list A) x :
  nth (l ++ x :: nil) (List.length l) = Some x.
Proof.
  induction l; simpl; try congruence.
Qed.

Lemma nth_len {A} (l : list A) :
  nth l (List.length l) = None.
Proof.
  induction l; simpl; try congruence.
Qed.

Lemma length_nth_upd {A} (l : list A) i x : List.length (nth_upd l i x) = List.length l.
Proof.
  revert i; induction l; intros [|i]; simpl; auto.
Qed.

Lemma nth_nth_upd' {A} i j l (x : A) :
  j <> i ->
  nth (nth_upd l i x) j = nth l j.
Proof.
  revert i j; induction l; simpl; intros [|] [|] ?; simpl; auto; congruence.
Qed.

(*+ Memory maps *)

Definition map := nat -> option nat.

Definition emptymap : map := fun _ => None.

Definition eqmap (m m' : map) := forall x, m x = m' x.

Lemma eqmap_eq m m' : eqmap m m' -> m = m'.
Proof.
  intros H; extensionality x. apply H.
Qed.

Instance eqmap_equiv : Equivalence eqmap.
Proof.
  split; compute; firstorder; congruence.
Qed.

Definition upd {A} (m : nat -> A) x e :=
  fun y => if eq_nat_dec x y then e else m y.

Definition updatemap (m : map) (x e : nat) : option map :=
  match m x with Some _ => Some (upd m x (Some e)) | None => None end.

Definition assertmap (m : map) (x : nat) : Prop :=
  match m x with Some (S _) => True | _ => False end.

Definition joincell (a b : option nat) : option (option nat) :=
  match a, b with
    | None, None => Some None
    | Some a, None | None, Some a => Some (Some a)
    | Some _, Some _ => None
  end.

Definition join (m n o : map) : Prop := forall x, joincell (m x) (n x) = Some (o x).
Definition joins (m n : map) : Prop := exists o, join m n o.

Add Parametric Morphism : join with signature eqmap ==> eqmap ==> eqmap ==> iff as join_morphism.
Proof.
  unfold eqmap, join, joincell.
  intros a b E c d F e f G; split; intros H x;
  specialize (H x);
  rewrite E, F, G in *;
  destruct (d x), (e x), (f x); congruence.
Qed.

Lemma join_eqmap_compat_l {m m' n o}  : eqmap m m' -> join m n o -> join m' n o.
Proof.
  intros E J x; specialize (J x); specialize (E x).
  destruct (m x), (n x); congruence.
Qed.

Lemma join_eqmap_compat_r {m n n' o}  : eqmap n n' -> join m n o -> join m n' o.
Proof.
  intros E J x; specialize (J x); specialize (E x).
  destruct (m x), (n x); congruence.
Qed.

Lemma join_eqmap {m n o o'}  : join m n o -> join m n o' -> eqmap o o'.
Proof.
  intros J J' x; specialize (J x); specialize (J' x).
  destruct (m x), (n x); congruence.
Qed.

Lemma join_eqmap_r {m n n' o}  : join m n o -> join m n' o -> eqmap n n'.
Proof.
  intros J J' x; specialize (J x); specialize (J' x).
  destruct (m x), (n x), (n' x), (o x); inversion J; inversion J'; congruence.
Qed.

Lemma join_eqmap_l {m m' n o}  : join m n o -> join m' n o -> eqmap m m'.
Proof.
  intros J J' x; specialize (J x); specialize (J' x).
  destruct (m x), (n x), (m' x), (o x); inversion J; inversion J'; congruence.
Qed.

Definition joincell_split {a b ab c abc} :
  joincell a b = Some ab -> joincell ab c = Some abc ->
  { bc | joincell b c = Some bc /\ joincell a bc = Some abc }.
Proof.
  destruct a, b, ab, c, abc; simpl; intros E F; try discriminate;
    eexists; intuition; try congruence.
Defined.

Lemma join_split a b ab c abc : join a b ab -> join ab c abc ->
  exists bc, join b c bc /\ join a bc abc.
Proof.
  intros H I.
  exists (fun x => proj1_sig (joincell_split (H x) (I x))); split; intros x; simpl;
    apply (proj2_sig (joincell_split (H x) (I x))).
Qed.

Lemma join_emptymap_l a : join emptymap a a.
Proof.
  intros x; destruct (a x); auto.
Qed.

Lemma join_emptymap_r a : join a emptymap a.
Proof.
  intros x; destruct (a x); auto.
Qed.

Lemma joins_emptymap_l a : joins emptymap a.
Proof.
  exists a; intros x; destruct (a x); auto.
Qed.

Lemma joins_emptymap_r a : joins a emptymap.
Proof.
  exists a; intros x; destruct (a x); auto.
Qed.

Lemma join_comm a b c : join a b c -> join b a c.
Proof.
  intros J x; rewrite <-J.
  destruct (a x), (b x); auto.
Qed.

Lemma joins_sym a b : joins a b -> joins b a.
Proof.
  intros [c J]; exists c; apply join_comm; auto.
Qed.

Hint Resolve
     join_emptymap_l
     join_emptymap_r
     joins_emptymap_l
     joins_emptymap_r
     join_comm
     joins_sym.

Lemma joins_pointwise m n : joins m n <-> (forall x, joincell (m x) (n x) <> None).
Proof.
  split.
  - intros [o H] x; rewrite (H x). congruence.
  - intros H.
    exists (fun x => match joincell (m x) (n x) with Some n => n | None => None end).
    intros x; destruct (joincell (m x) (n x)) eqn:E; auto.
    apply (H x) in E; tauto.
Qed.

Lemma join_joins_distrib a b ab : join a b ab -> forall c, joins ab c -> joins a c /\ joins b c.
Proof.
  intros H c [d J]; split; apply joins_pointwise; intros x;
    specialize (H x); specialize (J x);
      destruct (a x), (b x), (c x); simpl in *; try congruence;
        injection H; intros E; rewrite <-E in *; inversion J.
Qed.

Lemma join_joins_distrib' a b ab : join a b ab -> forall c, joins a c -> joins b c -> joins ab c.
Proof.
  intros H c [d J] [e I]; apply joins_pointwise; intros x;
    specialize (H x); specialize (J x); specialize (I x);
      destruct (a x), (b x), (c x); simpl in *; try congruence;
        injection H; intros E F; rewrite <-E in *; simpl; discriminate.
Qed.

Definition empty (m : map) : Prop := forall x, m x = None.

Lemma join_empty m n : empty n -> join m n m.
Proof.
  intros E x; rewrite E; destruct (m x); auto.
Qed.

Definition nonempty (m : map) : Prop := exists x, m x <> None.

Lemma eqmap_joins m1 m2 : joins m1 m2 -> eqmap m1 m2 -> empty m1 /\ empty m2.
Proof.
  intros [o J] EQ.
  cut (empty m1); [ intros E; split; intros x; auto; rewrite <- EQ; auto | ].
  intros x; specialize (J x); rewrite <-EQ in J.
  destruct (m1 x); auto; inversion J.
Qed.

(*+ Predicates *)

Definition pred := map -> Prop.

Definition sat (m : map) (P : pred) : Prop := P m.
(* Definition sat (m : map) (P : pred) : Prop := forall n, eqmap m n -> P n. *)

Infix " |= " := sat (at level 40).

Definition emp : pred := fun m => forall n, m n = None.

Definition TT : pred := fun m => True.

Definition FF : pred := fun m => False.

Definition imp (P Q : pred) : Prop := forall m, m |= P -> m |= Q.

Definition sepcon (P Q : pred) : pred :=
  fun m => exists m1 m2, join m1 m2 m /\ P m1 /\ Q m2.

Infix "**" := sepcon (at level 30).

Lemma imp_sepcon P Q F : imp P Q -> imp (P ** F) (Q ** F).
Proof.
  intros i m (m1 & m2 & J & H1 & H2).
  apply i in H1.
  compute; eauto.
Qed.

Definition pequiv (P Q : pred) := forall m, P m <-> Q m.

Infix " == " := pequiv (at level 50, no associativity).

Lemma pequiv_sym P Q : P == Q -> Q == P.
Proof.
  compute; firstorder.
Qed.

Lemma pequiv_imp P Q : P == Q -> imp P Q.
Proof.
  compute; firstorder.
Qed.

Lemma sepcon_comm P Q : P ** Q == Q ** P.
Proof.
  intros m; split; intros (p & q & J & Pp & Qq); exists q, p; intuition; eauto.
Qed.

Lemma sepcon_assoc P Q R : P ** (Q ** R) == (P ** Q) ** R.
Proof.
  intros m; split.
  - intros (p & qr & J & Pp & q & r & J' & Qq & Rr).
    apply join_comm in J.
    apply join_comm in J'.
    destruct (join_split _ _ _ _ _ J' J) as (pq & J'' & J''').
    exists pq, r; split; intuition.
    exists p, q; split; eauto.
  - intros (pq & r & J & (p & q & J' & Pp & Qq) & Rr).
    destruct (join_split _ _ _ _ _ J' J) as (qr & J'' & J''').
    exists p, qr; split; intuition.
    exists q, r; split; eauto.
Qed.

Lemma sepcon_emp P : emp ** P == P.
Proof.
  intros m; split.
  - intros (p & q & J & Pp & Qq).
    (* hmm we need P to be stable under pointwise equality *)
    replace m with q; auto.
    apply functional_extensionality.
    intros x.
    specialize (J x).
    rewrite (Pp x) in *.
    destruct (q x); inversion J; auto.
  - intros Pm.
    exists emptymap, m; split; intuition eauto.
    intro; reflexivity.
Qed.

Definition subheap m o := exists n, join m n o.

Definition precise (R : pred) : Prop := forall o m1 m2,
    m1 |= R -> m2 |= R ->
    subheap m1 o -> subheap m2 o -> eqmap m1 m2.

Lemma precise_FF : precise FF.
Proof.
  intros o m1 m2 [].
Qed.

Definition mapsto x v : pred := fun m => forall n, m n = if eq_nat_dec x n then Some v else None.

Definition mapsto_ x : pred := fun m => forall n, if eq_nat_dec x n then m n <> None else m n = None.

Lemma mapsto_mapsto_ x n m : mapsto x n m -> mapsto_ x m.
Proof.
  unfold mapsto, mapsto_.
  intros H y; rewrite (H y).
  destruct (eq_nat_dec x y); congruence.
Qed.

Lemma precise_mapsto x n : precise (mapsto x n).
Proof.
  intros o m1 m2 s1 s2 [n1 J1] [n2 J2] y.
  rewrite (s1 y), (s2 y); auto.
Qed.

Lemma precise_mapsto_ x : precise (mapsto_ x).
Proof.
  intros o m1 m2 s1 s2 [n1 J1] [n2 J2] y.
  specialize (s1 y).
  specialize (s2 y).
  ifeq; try congruence.
  specialize (J1 y).
  specialize (J2 y).
  destruct (m1 y); try congruence.
  destruct (m2 y); try congruence.
  destruct (n1 y); try congruence; try inversion J1.
  destruct (n2 y); try congruence; try inversion J2.
  congruence.
Qed.

Lemma precise_join R m1 m2 : precise R -> m1 |= R -> m2 |= R -> joins m1 m2 -> empty m1 /\ empty m2.
Proof.
  intros PR s1 s2 [o J].
  assert (S1:subheap m1 o) by (unfold subheap; eauto).
  assert (S2:subheap m2 o) by (unfold subheap; eauto).
  specialize (PR o _ _ s1 s2 S1 S2).
  apply eqmap_joins; unfold joins; eauto.
Qed.

(*+ Oracular semantics *)

(** Single-thread oracular semantics: each thread assumes that the
    oracle provides maps satisfying the invariants, but the thread
    also have to give back maps that satisfy those invariants. *)

Record globals := mkglobals
  { resinvs : nat -> pred (* resource invariant for each lock *) ;
    funspecs : string -> option pred (* precondition of each function *)
  }.

Reserved Notation " c1 ---> c2 " (at level 50).

Definition oracle := list map.

Inductive step : Rel (globals * oracle * map * list instruction) :=
  | step_halted G oracle m :
      (G, oracle, m, nil) --->
      (G, oracle, m, nil)
  | step_set G oracle m m' x e p :
      updatemap m x e = Some m' ->
      (G, oracle, m, set x e :: p) --->
      (G, oracle, m', p)
  | step_assert G oracle m x p :
      assertmap m x ->
      (G, oracle, m, assert x :: p) --->
      (G, oracle, m, p)
  | step_release G oracle m mlock m' l p :
      mlock |= resinvs G l ->
      join m' mlock m ->
      (G, oracle, m, release l :: p) --->
      (G, oracle, m', p)
  | step_acquire G oracle m mlock m' l p :
      mlock |= resinvs G l ->
      join m mlock m' ->
      (G, mlock :: oracle, m, acquire l :: p) --->
      (G, oracle, m', p)
  | step_acquire_wrong_oracle G oracle m mlock l p :
      ~(mlock |= resinvs G l /\ joins m mlock) ->
      (G, mlock :: oracle, m, acquire l :: p) --->
      (G, mlock :: oracle, m, acquire l :: p)
  | step_acquire_empty_oracle G m l p :
      (G, nil, m, acquire l :: p) --->
      (G, nil, m, acquire l :: p)
  | step_spawn G PRE oracle m mspawned m' f p :
      funspecs G f = Some PRE ->
      mspawned |= PRE ->
      join m' mspawned m ->
      (G, oracle, m, spawn f :: p) --->
      (G, oracle, m', p)
where
" c1 ---> c2 " := (step  c1 c2).

Hint Constructors step.

(*+ Concurrent machine *)

(** Semantics of the collection of all threads. Thread and locked
    locks each have their own map. *)

Definition schedule := list nat.

Definition threads := list (map * list instruction).

Definition lockpool := nat -> option map.

Definition functions := string -> option (list instruction).

Definition config := (schedule * functions * globals * threads * lockpool)%type.

Reserved Notation " c1 ===> c2 " (at level 50).

(** reasons for having a list of threads rather than a function nat ->
option thread ? 1) It's a bit more deterministic and hence slighlty
easier to prove sound.  2) We can always allocate new threads. 3)
people prefer that, apparently *)

Inductive machine : Rel config :=
  | machine_outofschedule F G thd pool :
      (nil, F, G, thd, pool) ===>
      (nil, F, G, thd, pool)
  | machine_scheduleoutofbound i sch F G thd pool :
      nth thd i = None ->
      (i :: sch, F, G, thd, pool) ===>
      (sch, F, G, thd, pool)
  | machine_set i sch F G thd m m' x e p pool :
      nth thd i = Some (m, set x e :: p) ->
      updatemap m x e = Some m' ->
      (i :: sch, F, G, thd, pool) ===>
      (i :: sch, F, G, nth_upd thd i (m', p), pool)
  | machine_assert i sch F G thd m x p pool :
      nth thd i = Some (m, assert x :: p) ->
      assertmap m x ->
      (i :: sch, F, G, thd, pool) ===>
      (i :: sch, F, G, nth_upd thd i (m, p), pool)
  | machine_release i sch F G thd m mlock m' l p pool :
      nth thd i = Some (m, release l :: p) ->
      mlock |= resinvs G l ->
      join m' mlock m ->
      (i :: sch, F, G, thd, pool) ===>
      (sch, F, G, nth_upd thd i (m', p), upd pool l (Some mlock))
  | machine_acquire_failure i sch F G thd m l p pool :
      nth thd i = Some (m, acquire l :: p) ->
      pool l = None (* locked *) ->
      (i :: sch, F, G, thd, pool) ===>
      (sch, F, G, thd, pool)
  | machine_acquire_success i sch F G thd m mlock m' l p pool :
      nth thd i = Some (m, acquire l :: p) ->
      pool l = Some mlock (* unlocked *) ->
      join m mlock m' ->
      (i :: sch, F, G, thd, pool) ===>
      (i :: sch, F, G, nth_upd thd i (m', p), upd pool l None)
  | machine_halted i sch F G thd m pool :
      nth thd i = Some (m, nil) ->
      (i :: sch, F, G, thd, pool) ===>
      (sch, F, G, thd, pool)
  | machine_spawn i sch F G PRE thd m mspawned prog m' f p pool :
      nth thd i = Some (m, spawn f :: p) ->
      funspecs G f = Some PRE ->
      mspawned |= PRE ->
      F f = Some prog ->
      join m' mspawned m ->
      (i :: sch, F, G, thd, pool) ===>
      (sch, F, G, nth_upd thd i (m', p) ++ (mspawned, prog) :: nil, pool)
where
" c1 ===> c2 " := (machine c1 c2).

(** Note that we do not consume the schedule in machine_set,
    machine_assert and machine_aquire_success.  We could, which would
    make the semantics more fine-grained (the proofs below are not
    affected at all by this change) *)

Hint Constructors machine.

(*+ Collection of disjoint maps *)

(** For the proof of composition of safety, we need to maintain the
    invariants "all the maps are disjoint*" which is why we need this
    section.

  * pairwise-disjointness is equivalent to arbitrary disjointness
    because the permissions are "set-theoretical" *)

Definition selfjoins {A} (maps : A -> map) :=
  forall i j, i <> j -> joins (maps i) (maps j).

Definition sameperms (m n : map) := forall x, m x = None <-> n x = None.

Lemma sameperms_refl m : sameperms m m.
Proof.
  compute; tauto.
Qed.

Lemma sameperms_sym m n : sameperms m n -> sameperms n m.
Proof.
  compute; intros S x; specialize (S x); intuition.
Qed.

Lemma sameperms_trans m n o : sameperms m n -> sameperms n o -> sameperms m o.
Proof.
  compute; intros S T x; specialize (S x); specialize (T x); intuition.
Qed.

Hint Resolve sameperms_refl sameperms_sym sameperms_trans.

Lemma sameperms_updatemap m x e m' : updatemap m x e = Some m' -> sameperms m m'.
Proof.
  unfold updatemap, upd; destruct (m x) eqn:E; intros U i; inversion U; subst; clear U.
  ifeq; intuition; congruence.
Qed.

Lemma sameperms_joins m m' n : sameperms m m' -> joins m n -> joins m' n.
Proof.
  intros S [o J].
  exists (fun x => match m' x, n x with
           | None, None => None
           | None, Some n | Some n, None => Some n
           | Some _, Some _ => None end).
  intros x.
  specialize (J x); specialize (S x).
  destruct (m x) eqn:D, (m' x) eqn:E, (n x) eqn:F; auto.
  - inversion J.
  - intuition.
    discriminate.
Qed.

Hint Resolve sameperms_updatemap.

Lemma selfjoins_sameperms_compat {A} maps1 maps2 : (forall i:A, sameperms (maps1 i) (maps2 i)) -> selfjoins maps1 -> selfjoins maps2.
Proof.
  intros S J i j ij.
  specialize (J i j ij).
  pose proof (S i); pose proof (S j).
  eapply sameperms_joins; eauto.
  apply joins_sym.
  eapply sameperms_joins; eauto.
Qed.

Definition swapped {A} (m1 m2 : A -> map) i j a b c d :=
  m1 i = a /\
  m1 j = b /\
  m2 i = c /\
  m2 j = d /\
  forall k, k <> i -> k <> j -> m1 k = m2 k.

Lemma selfjoins_swapped {A} {m1 m2 : A -> map} (Adec:forall x y:A,{x=y}+{x<>y})
      i j (J:selfjoins m1) e a b c d :
  swapped m1 m2 i j a b c d ->
  join a b e ->
  join c d e ->
  selfjoins m2.
Proof.
  intros (<- & <- & <- & <- & diff) ab cd x y xy.
  pose proof join_joins_distrib' _ _ _ ab.
  destruct (Adec x i) as [xi|xi];
  destruct (Adec x j) as [xj|xj];
  destruct (Adec y i) as [yi|yi];
  destruct (Adec y j) as [yj|yj]; try congruence; try subst x; try subst y;
    try (assert (y': m1 y = m2 y) by (apply diff; auto));
    try (assert (x': m1 x = m2 x) by (apply diff; auto));
    repeat match goal with
             [ H : ?p <> ?q |- _ ] => pose proof (J _ _ H); clear H
           end; try rewrite <-x' in *; try rewrite <-y' in *;
      solve
        [ auto
        | eexists; eauto
        | apply (join_joins_distrib _ _ _ cd); auto
        | apply joins_sym, (join_joins_distrib _ _ _ cd); auto ].
Qed.

Definition reindex (thd:threads) pool : _ -> map :=
  fun x : nat + nat =>
           match x with
           | inl n =>
             match nth thd n with
             | Some (m, _) => m
             | None => emptymap
             end
           | inr n =>
             match pool n with
             | Some m => m
             | None => emptymap
             end
           end.

Lemma natnateqdec (x y : nat + nat) : {x=y}+{x<>y}. repeat decide equality. Defined.

(*+ Composing safety of several threads *)

(** If each thread behaves well (assuming a good oracle) then running
    those threads in a concurrent machine is safe, too.  The proof
    builds a good oracle for each thread so that each thread follows
    the steps of the machine. *)

Definition lockpool_matches (pool : lockpool) RI :=
  forall l, match pool l with Some m => m |= RI l | None => True end.

Definition functions_safe G F :=
  forall f, match funspecs G f, F f with
       | Some P, Some p =>
         forall m oracle, P m -> safe step (G, oracle, m, p)
       | None, None => True
       | _, _ => False
       end.

Ltac funspecs_inv :=
  match goal with
  | FF : functions_safe ?G ?F |- _ =>
    match goal with
    | FSf : funspecs G ?f = Some _ |- _ =>
      let H := fresh "Hsafe" in
      let p := fresh "p" in
      let E := fresh "E" in
      pose proof FF f as H;
      destruct (F f) as [p|] eqn:E;
      rewrite FSf in H; [|tauto]
    | Ff : F ?f = Some _ |- _ =>
      let H := fresh "Hsafe" in
      let P := fresh "PRE" in
      let E := fresh "E" in
      pose proof FF f as H;
      destruct (funspecs G f) as [P|] eqn:E;
      rewrite Ff in H; [|tauto]
    end
  end.

(* Our invariant:
 - resource invariants are precise (no need for them to be positive)
 - all the functions are safe (given a precondition)
 - lock pool maps and threads maps are disjoint
 - lock pool maps match the resource invariants
 - all threads are safe for n steps
*)

Definition P (x : config) :=
  match x with (_, F, G, thd, pool) =>
    (forall l, precise (resinvs G l)) /\
    functions_safe G F /\
    selfjoins (reindex thd pool) /\
    lockpool_matches pool (resinvs G) /\
    (forall i oracle m p,
        nth thd i = Some (m, p) ->
        safe step (G, oracle, m, p))
  end.

(* Progress : the invariant implies we can take a machine step *)

Theorem progress x : P x -> exists y, x ===> y.
Proof.
  destruct x as (((([|i sch], F), G), thd), pool). eexists; constructor.
  intros (_ & FF & J & _ & S).
  + destruct (nth thd i) as [[m p]|] eqn:E; [ | eauto].
    destruct (S i nil m p E _ (star_refl _ _)) as [z Hz].
    inversion Hz; subst.
    - eauto.
    - eexists. eapply machine_set; reflexivity || eauto.
    - eexists. eapply machine_assert; reflexivity || eauto.
    - eexists. eapply machine_release; reflexivity || eauto.
    - clear Hz (* the oracle is actually used here, z/Hz is useless. *).
      destruct (J (inl i) (inr l)) as [o Jl]; [congruence|]; simpl in Jl; rewrite E in *.
      destruct (pool l) eqn:El (* is the pool lock unlocked or locked? *).
      * eexists. eapply machine_acquire_success; simpl; eauto.
      * eexists. eapply machine_acquire_failure; simpl; eauto.
    - funspecs_inv.
      eexists. eapply machine_spawn; reflexivity || eauto.
Qed.

Tactic Notation "rewr" :=
  match goal with
  | H : ?f = _ |- context [?f] => rewrite H
  | H : ?f _ = ?f _ |- _ => try (injection H; repeat intros ->)
  end.

Tactic Notation "rewr" constr(e) := match goal with E : e = _ |- _ => rewrite E | E : _ = e |- _ => rewrite <-E end.
Tactic Notation "rewr" constr(e) "in" "*" := match goal with E : e = _ |- _ => rewrite E in * | E : _ = e |- _ => rewrite <-E in * end.
Tactic Notation "rewr" constr(e) "in" hyp(H) := match goal with E : e = _ |- _ => rewrite E in H | E : _ = e |- _ => rewrite <-E in H end.

(* Subject reduction : taking a step let us stay in the invariant *)

Theorem subject_reduction x y : x ===> y -> P x -> P y.
Proof.
  destruct x as (((([|i sch], F), G), thd), pool);
    intros xy; inversion xy; subst; intros (PR & FF & J & M & S);
      simpl fst in *; simpl snd in *.

  - (* out of schedule *)
    hnf; intuition; eauto.

  - (* schedule out of bound *)
    hnf; intuition; eauto.

  - (* set *)
    repeat split; auto.
    + eapply selfjoins_sameperms_compat; [..|apply J]; intros [k|]; simpl; eauto.
      erewrite nth_nth_upd; [|eassumption].
      ifeq; subst; auto.
      rewr; eauto.
    + intros j oracle; specialize (S j oracle).
      erewrite nth_nth_upd; [|eassumption].
      ifeq; subst; auto.
      intros. rewr.
      eapply safe_R; eauto.

  - (* assert *)
    repeat split; auto.
    + eapply selfjoins_sameperms_compat; [..|apply J]; intros [k|]; simpl; eauto.
      erewrite nth_nth_upd; [|eassumption].
      ifeq; subst; auto.
      rewr; eauto.
    + intros j oracle; specialize (S j oracle).
      erewrite nth_nth_upd; [|eassumption].
      ifeq; subst; auto.
      intros. rewr.
      eapply safe_R; eauto.

  - (* release *)
    simpl; repeat split; auto.
    + assert (Empl : match pool l with None => True | Some ml => empty ml end). {
        destruct (pool l) as [ml|] eqn:E; auto.
        cut (empty ml /\ empty mlock);[intuition|].
        apply precise_join with (resinvs G l); eauto.
        - specialize (M l); rewrite E in M; auto.
        - assert (D:inl i <> inr l) by congruence.
          specialize (J _ _ D); simpl in J.
          rewr (nth thd i) in J.
          rewr (pool l) in J.
          pose proof (join_joins_distrib m' mlock m H8 ml); intuition eauto.
      }
      eapply (selfjoins_swapped natnateqdec (inl i) (inr l) J).
      * unfold swapped, reindex, upd; repeat split.
        intros [|] a b; [ | ifeq; congruence].
        erewrite nth_nth_upd;[|eassumption].
        ifeq; congruence.
      * apply join_empty; simpl.
        destruct (pool l) as [ml|]; unfold empty; auto.
      * erewrite nth_nth_upd;[|eassumption].
        ifeq; ifeq.
        rewr; eauto.
    + intros k; unfold upd; ifeq; subst; auto. apply M.
    + intros j oracle; specialize (S j oracle).
      erewrite nth_nth_upd; [|eassumption].
      ifeq; subst; auto.
      intros. rewr.
      eapply safe_R; eauto.

  - (* acquire (locked) *)
    repeat split; eauto.

  - (* acquire (unlocked) *)
    repeat split; auto.
    + eapply (selfjoins_swapped natnateqdec (inl i) (inr l) J).
      * unfold swapped, reindex, upd; repeat split.
        intros [|] a b; try (ifeq; congruence).
        erewrite nth_nth_upd;[|eassumption].
        ifeq; congruence.
      * rewr. rewr. eauto.
      * rewr. ifeq.
        erewrite nth_nth_upd;[|eassumption].
        ifeq. auto.
    + intros k; unfold upd; ifeq; subst; auto. apply M.
    + intros j oracle.
      erewrite nth_nth_upd; [|eassumption].
      ifeq; subst; eauto.
      specialize (S j (mlock :: oracle)).
      intros; rewr.
      specialize (M l); rewr (pool l) in *.
      eapply safe_R; eauto.

  - (* halted *)
    repeat split; eauto.

  - (* spawn *)
    repeat split; auto.
    + eapply (selfjoins_swapped natnateqdec (inl i) (inl (List.length thd)) J).
      * unfold swapped, reindex, upd; repeat split.
        intros [k|l] a b; try (ifeq; congruence); auto.
        rewrite nth_snoc. 2:rewrite length_nth_upd; auto.
        rewrite nth_nth_upd'. 2:auto.
        auto.
      * rewr. rewrite nth_len. eauto.
      * auto.
        erewrite <-length_nth_upd.
        rewrite nth_snoc_len.
        rewrite nth_snoc. 2:rewrite length_nth_upd; intros ->. 2:rewrite nth_len in H6; discriminate.
        erewrite nth_nth_upd;[|eassumption].
        ifeq; eauto.
    + intros j oracle.
      destruct (eq_nat_dec j (List.length thd)).
      * (* safety of new thread *)
        subst j.
        intros m'' p''.
        erewrite <-length_nth_upd.
        rewrite nth_snoc_len.
        intros E; rewr.
        funspecs_inv.
        replace p0 with p'' in * by congruence.
        auto.
      * (* safety of spawner thread *)
        rewrite nth_snoc. 2:rewrite length_nth_upd; congruence.
        specialize (S j oracle).
        erewrite nth_nth_upd; [|eassumption].
        ifeq; subst; auto.
        intros. rewr.
        eapply safe_R; eauto.
Qed.

Lemma P_safe x : P x -> safe machine x.
Proof.
  intros Px y it.
  apply progress.
  induction it; simpl; auto.
  apply IHit.
  eapply subject_reduction; eauto.
Qed.

Theorem soundness sch F G thd pool :
  (forall l, precise (resinvs G l)) ->
  selfjoins (reindex thd pool) ->
  lockpool_matches pool (resinvs G) ->
  functions_safe G F ->
  (forall i oracle m p,
      nth thd i = Some (m, p) ->
      safe step (G, oracle, m, p)) ->
  safe machine (sch, F, G, thd, pool).
Proof.
  intros PR J M FF SS.
  apply P_safe; unfold P; intuition.
Qed.

(*+ Hoare logic (single thread) *)

(** We now build a Hoare logic for a single thread based on the
    oracular semantics (it can assume that acquire will give back a
    good map, but has to provide back good maps at release.) *)

Definition safe_onethread G P c :=
  forall m, m |= P -> forall oracle, safe step (G, oracle, m, c).

Definition semax G P c Q := forall F k,
    safe_onethread G (Q ** F) k ->
    safe_onethread G (P ** F) (c ++ k).

Lemma semax_app G P Q R c1 c2 : semax G P c1 Q -> semax G Q c2 R -> semax G P (c1++c2) R.
Proof.
  intros H1 H2 k Sk.
  rewrite app_ass; auto.
Qed.

Lemma semax_nil G P : semax G P nil P.
Proof.
  compute; auto.
Qed.

Lemma semax_cons G P Q R i c : semax G P (i :: nil) Q -> semax G Q c R -> semax G P (i :: c) R.
Proof.
  intros; eapply (semax_app _ _ _ _ (i :: nil) c); eauto.
Qed.

Lemma updatemap_mapsto_ x n' n m :
  (mapsto_ x m \/ mapsto x n' m) ->
  exists m', updatemap m x n = Some m' /\ mapsto x n m'.
Proof.
  intros H.
  assert (M : mapsto_ x m) by (intuition; eapply mapsto_mapsto_; eauto); clear H.
  destruct (updatemap m x n) as [m'|] eqn:E; [exists m'; split;auto|].
  - intros y; pose proof (M x) as Mx;  pose proof (M y) as My.
    ifeq.
    unfold updatemap in *.
    destruct (m x); [|congruence].
    injection E; clear E; intro; subst.
    unfold upd.
    ifeq; auto.
  - exfalso.
    specialize (M x); ifeq.
    unfold updatemap in *.
    destruct (m x); congruence.
Qed.

Lemma updatemap_mapsto_frame F x n m :
  m |= mapsto_ x ** F ->
  exists m', updatemap m x n = Some m' /\ m' |= mapsto x n ** F.
Proof.
  intros (m1 & m2 & J & s1 & s2).
  destruct (updatemap_mapsto_ x 0 n _ (or_introl s1)) as (m1' & E & s1').
  unfold updatemap in *.
  destruct (m x) eqn:Ex.
  - eexists; repeat split.
    exists m1', m2; repeat split; auto.
    intros y; specialize (J y).
    destruct (m1 x) eqn:E1; [injection E; intro; subst; clear E|discriminate].
    unfold upd; ifeq; auto.
    subst.
    rewrite E1 in J.
    destruct (m2 y). inversion J. auto.
  - specialize (J x); rewrite Ex in J.
    destruct (m1 x) eqn:E1; [injection E; intro; subst; clear E|discriminate].
    destruct (m2 x); inversion J.
Qed.

Lemma semax_set G x e : semax G (mapsto_ x) (set x e :: nil) (mapsto x e).
Proof.
  intros F k Sk m sat oracle; simpl.
  destruct (updatemap_mapsto_frame _ _ e _ sat) as (m', (E, Hm')).
  specialize (Sk m' Hm' oracle).
  apply (safe_det _ _ _ Sk).
  - constructor; auto.
  - intros Y SY; inversion SY; subst.
    repeat f_equal; congruence.
Qed.

Lemma semax_assert G x n : n <> 0 -> semax G (mapsto x n) (assert x :: nil) (mapsto x n).
Proof.
  intros P F k Sk m sat oracle.
  specialize (Sk m sat oracle).
  apply (safe_det _ _ _ Sk).
  - constructor.
    unfold assertmap.
    destruct sat as (m1 & m2 & J & s1 & s2).
    specialize (J x).
    specialize (s1 x); ifeq.
    destruct n, (m1 x), (m2 x), (m x); try congruence; inversion J; subst.
    destruct n1; auto; congruence.
  - intros Y SY; inversion SY; subst.
    repeat f_equal; congruence.
Qed.

Lemma safe_onethread_implies G (P P' : pred) c :
  imp P' P ->
  safe_onethread G P c -> safe_onethread G P' c.
Proof.
  unfold imp, safe_onethread; auto.
Qed.

Lemma semax_frame G P c Q F : semax G P c Q -> semax G (P ** F) c (Q ** F).
Proof.
  intros S F' k Sk m sat oracle.
  refine (S (F ** F') k _ m _ oracle).
  - eapply safe_onethread_implies; eauto.
    apply pequiv_imp, sepcon_assoc.
  - revert sat; apply pequiv_imp, pequiv_sym, sepcon_assoc.
Qed.

Lemma semax_acquire' G l : (forall P, P \/ ~P) -> semax G emp (acquire l :: nil) (resinvs G l).
Proof.
  intros EM F k Sk m sat oracle; simpl.
  destruct oracle as [|mlock oracle].
  - apply safe_selfloop. constructor.
    intros y step; inversion step; auto.
  - destruct (EM (mlock |= resinvs G l /\ joins m mlock)) as [[s [m' J]]|nok].
    + assert (s' : m' |= resinvs G l ** F).
      { exists mlock, m; intuition.
        eapply pequiv_imp in sat; [ | apply sepcon_emp ]; auto.
      }
      specialize (Sk m' s' oracle).
      eapply safe_det; eauto.
      intros y' step; inversion step; subst; auto.
      * repeat f_equal.
        apply eqmap_eq.
        eapply join_eqmap; eauto.
      * assert (joins m mlock) by (eexists; eauto).
        tauto.
    + apply safe_selfloop. constructor. tauto.
      intros y step; inversion step; auto; subst.
      assert (joins m mlock) by (eexists; eauto).
      tauto.
Qed.

Lemma semax_pre G (P P' : pred) c Q :
  imp P' P ->
  semax G P c Q -> semax G P' c Q.
Proof.
  intros I Se F k Sa.
  eapply safe_onethread_implies with (P ** F); eauto.
  apply imp_sepcon, I.
Qed.

Lemma semax_post G P c (Q Q' : pred) :
  imp Q Q' ->
  semax G P c Q -> semax G P c Q'.
Proof.
  intros I Se F k Sa.
  apply Se.
  eapply safe_onethread_implies with (Q' ** F); auto.
  apply imp_sepcon, I.
Qed.

Lemma semax_acquire G l F :  (forall P, P \/ ~P) -> semax G F (acquire l :: nil) (resinvs G l ** F).
Proof.
  intros EM.
  apply semax_pre with (emp ** F).
  - apply pequiv_imp, pequiv_sym, sepcon_emp.
  - apply semax_frame, semax_acquire'; auto.
Qed.

Lemma semax_release' G l : precise (resinvs G l) -> semax G (resinvs G l) (release l :: nil) emp.
Proof.
  intros PR F k Sk m sat oracle; simpl.
  destruct sat as (mlock & m' & J & sl & s').
  assert (s'' : m' |= emp ** F). {
    refine (pequiv_imp _ _ _ _ s').
    apply pequiv_sym, sepcon_emp. }
  specialize (Sk m' s'' oracle).
  apply (safe_det _ _ _ Sk).
  - apply step_release with mlock; auto.
  - intros Y SY; inversion SY; subst.
    repeat f_equal.
    apply join_comm in J.
    cut (eqmap mlock mlock0).
    { intros E; apply (join_eqmap_compat_r E) in J.
      eapply eqmap_eq, (join_eqmap_l J); eauto. }
    refine (PR m _ _ sl _ _ _); unfold subheap; eauto.
Qed.

Lemma semax_release G l F : precise (resinvs G l) -> semax G (resinvs G l ** F) (release l :: nil) F.
Proof.
  intros PR.
  apply semax_post with (emp ** F).
  { apply pequiv_imp, sepcon_emp. }
  apply semax_frame, semax_release'; auto.
Qed.

Lemma safe_nil G P : safe_onethread G P nil.
Proof.
  intros m sat oracle.
  remember (G, oracle, m, nil) as x.
  intros z Sz; exists x.
  cut (x = z).
  { intros <-; subst; constructor. }
  induction Sz; auto; subst.
  inversion H; subst; auto.
Qed.

Lemma semax_safe G P c : semax G P c TT -> safe_onethread G P c.
Proof.
  intros S; specialize (S emp nil (safe_nil _ _)).
  rewrite app_nil_r in S.
  refine (safe_onethread_implies _ _ _ _ _ S); clear.
  intros m; exists m, (fun _ => None); compute; intuition.
  destruct (m x); auto.
Qed.

(*+ Example *)

Ltac forward :=
  first [
      apply semax_nil
    | eapply semax_cons; [ eapply semax_set | ]
    | eapply semax_cons; [ eapply semax_assert | ]
    | eapply semax_cons; [ eapply semax_acquire' | ]
    | eapply semax_cons; [ eapply semax_acquire | ]
    | eapply semax_cons; [ eapply semax_release' | ]
    | eapply semax_cons; [ eapply semax_release | ]
    | eapply semax_cons
    ]; auto.

(* The following example show that running two (or more) copies of the
following program is safe:

  acquire;
  x := 1;
  release;
  acquire;
  assert x != 0
*)

Example even (sch : schedule) :
  (forall P, P \/ ~P) ->
  let odd n := exists m, n = 1 + 2 * m in
  let mpool : map := fun x => if eq_nat_dec x 5 then Some 1 else None in
  let pool : lockpool := fun l => if eq_nat_dec l 0 then Some mpool else None in
  let c := acquire 0 :: set 5 1 :: release 0 :: acquire 0 :: assert 5 :: nil in
  let RI := fun l => if eq_nat_dec l 0 then mapsto 5 1 else FF in
  let F : functions := fun _ => None in
  let FS := fun _ => None in
  let G := mkglobals RI FS in
  safe machine (sch, F, G, (emptymap, c) :: (emptymap, c) :: nil, pool).
Proof.
  intros EM odd mpool pool c RI F FS G.
  assert (emptymap |= emp) by (compute; auto).
  assert (PR : forall l, precise (RI l)). {
    intros l; unfold RI; ifeq.
    apply precise_mapsto.
    apply precise_FF.
  }
  cut (safe_onethread G emp c).
  { intros Sc.
    apply soundness; auto.
    - intros [[|[|n]]|[|[|n]]] [[|[|m]]|[|[|m]]] E;
      apply joins_emptymap_l || apply joins_emptymap_r || congruence.
    - unfold pool, RI, mpool; intros l; ifeq; subst; auto.
      intro x; ifeq; ifeq; congruence.
    - compute; auto.
    - intros [|[|i]] or m p E; inversion E; subst; eauto.
  }
  apply semax_safe.
  assert (r: resinvs G 0 = mapsto 5 1) by reflexivity.

  forward.
  rewrite r.
  apply semax_pre with (mapsto_ 5); [ intros x; apply mapsto_mapsto_ | ].
  forward.
  rewrite <-r.
  forward.
  forward.
  rewrite r.
  forward.
  apply semax_pre with TT. compute; auto.
  forward.
Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)

Require Import ssreflect.
Require Import ssrbool.
Require Import TestSuite.ssr_mini_mathcomp.

Variable T : Type.
Variables P : T -> Prop.

Definition f := fun x y : T => x.

Lemma test1 : forall x y : T, P (f x y) -> P x.
Proof.
move=> x y; set fxy := f x y; move=> Pfxy.
wlog H : @fxy Pfxy / P x.
  match goal with |- (let fxy0 := f x y in P fxy0 -> P x -> P x) -> P x => by auto | _ => fail end.
exact: H.
Qed.

Lemma test2 : forall x y : T, P (f x y) -> P x.
Proof.
move=> x y; set fxy := f x y; move=> Pfxy.
wlog H : fxy Pfxy / P x.
  match goal with |- (forall fxy, P fxy -> P x -> P x) -> P x => by auto | _ => fail end.
exact: H.
Qed.

Lemma test3 : forall x y : T, P (f x y) -> P x.
Proof.
move=> x y; set fxy := f x y; move=> Pfxy.
move: {1}@fxy (Pfxy) (Pfxy).
match goal with |- (let fxy0 := f x y in P fxy0 -> P fxy -> P x) => by auto | _ => fail end.
Qed.

Lemma test4 : forall n m z: bool, n = z -> let x := n in x = m && n -> x = m && n.
move=> n m z E x H.
case: true.
  by rewrite {1 2}E in (x) H |- *.
by rewrite {1}E in x H |- *.
Qed.


Require Import AutoSep.

(** Read from pointers in variables *)

Definition indirS : spec := SPEC("x") reserving 1
  Al v,
  PRE[V] V "x" =*> v
  POST[R] [| R = v |] * V "x" =*> v.

Definition indir := bmodule "indir" {{
  bfunction "indir"("x", "y") [indirS]
    "y" <-* "x";;
    Return "y"
  end
}}.

Theorem indirOk : moduleOk indir.
  vcgen; abstract sep_auto.
Qed.

Definition doubleIndirS : spec := SPEC("x") reserving 1
  Al p, Al v,
  PRE[V] V "x" =*> p * p =*> v
  POST[R] [| R = v |] * V "x" =*> p * p =*> v.

Definition doubleIndir := bmodule "doubleIndir" {{
  bfunction "doubleIndir"("x", "y") [doubleIndirS]
    "y" <-* "x";;
    "y" <-* "y";;
    Return "y"
  end
}}.

Theorem doubleIndirOk : moduleOk doubleIndir.
(*TIME Clear Timing Profile. *)
  vcgen; abstract sep_auto.
(*TIME Print Timing Profile. *)
Qed.


From CoindSemWhile Require Import SsrExport Trace Language SmallRel BigRel BigFunct.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(* one-step reduction function *)
Fixpoint red (s: stmt) (st: state) {struct s}: option (stmt * state) :=
match s with
| Sskip => None
| (Sassign x a) => Some (Sskip, update x (a st) st)
| (Sseq s1 s2) =>
  match red s1 st with
  | Some (s1', st') => Some (Sseq s1' s2, st')
  | None => red s2 st
  end
| (Sifthenelse a s1 s2) =>
  if is_true (a st) then Some (s1, st) else Some (s2, st)
| (Swhile a s) =>
  if is_true (a st)  then Some (Sseq s (Swhile a s), st)
  else Some (Sskip, st)
end.

(* small-step functional semantics *)
CoFixpoint Redm (s: stmt) (st: state): trace :=
match red s st with
| None => Tnil st
| Some (s', st') => Tcons st (Redm s' st')
end.

Lemma red_then_stop: forall s st,
red s st = None -> stop s.
Proof.
move => s; induction s.
- move => st h1. by apply stop_skip.
- move => st h1. by inversion h1.
- move => st h1. foo h1. case_eq (red s1 st).
  - move => [s1'  st'] h2. rewrite h2 in H0. by inversion H0.
  - move => h2. rewrite h2 in H0. by have := stop_seq (IHs1 _ h2) (IHs2 _ H0); apply.
- move => st h1. foo h1.  case_eq (is_true (e st)); move => h2.
  - rewrite h2 in H0. by inversion H0.
  - rewrite h2 in H0. by inversion H0.
- move => st h1. foo h1. case_eq (is_true (e st)); move => h2.
  - rewrite h2 in H0. by inversion H0.
  - rewrite h2 in H0. by inversion H0.
Qed.

Lemma red_then_step: forall s st s' st',
red s st = Some (s', st') -> step s st s' st'.
Proof.
move => s; induction s.
- move => st s st' h1. by inversion h1.
- move => st s st' h1. foo h1. by apply step_assign.
- move => st1 s3 st2 h1. case_eq (red s1 st1).
  - move => [s1' st1'] h2. foo h1. rewrite h2 in H0. foo H0.
    apply: step_seq1. by have := IHs1 _ _ _ h2; apply.
  - move => h2. foo h1. rewrite h2 in H0.
    by have := step_seq2 (red_then_stop h2) (IHs2 _ _ _ H0); apply.
- move => st1 s3 st2 h1. case_eq (is_true (e st1)) => h2.
  - simpl in h1. rewrite h2 in h1. foo h1.
    apply: step_ifthenelse_true. by apply h2.
  - simpl in h1. rewrite h2 in h1. foo h1.
    apply: step_ifthenelse_false. by apply h2.
- move => st s' st' h1. case_eq (is_true (e st)) => h2.
  - simpl in h1. rewrite h2 in h1. foo h1. apply: step_while_true.
    by apply h2.
  - simpl in h1. rewrite h2 in h1. foo h1.
    apply: step_while_false. by apply h2.
Qed.

Lemma stop_then_red: forall s st, stop s -> red s st = None.
Proof.
induction 1.
- by simpl.
- simpl. rewrite IHstop1. by apply IHstop2.
Qed.

Lemma step_then_red: forall s st s' st',
step s st s' st' -> red s st = Some (s', st').
Proof.
induction 1.
- by simpl.
- simpl. rewrite IHstep. simpl. done.
- simpl. have h1 := stop_then_red st H. rewrite h1. rewrite IHstep. done.
- simpl. rewrite H. done.
- simpl. by rewrite H.
- simpl. by rewrite H.
- simpl. by rewrite H.
Qed.

(* the small-step functional semantics correct wrt the small-step relational semantics. *)
Lemma Redm_correct_redm: forall st s, redm s st (Redm s st).
Proof.
cofix COINDHYP. move => st s. rewrite [Redm s st]trace_destr.
simpl. case_eq (red s st).
- move => [s' st'] h1. simpl. have h2 := red_then_step h1.
  have := redm_step h2; apply. by apply COINDHYP.
- move => h1. apply redm_stop. by have := red_then_stop h1; apply.
Qed.

(* the small-step relational semantics correct wrt the small-step functional semantics *)
Lemma redm_correct_Redm: forall s st tr, redm s st tr -> bisim tr (Redm s st).
Proof.
move => s st tr h1. have h2 := Redm_correct_redm st s.
by have := redm_deterministic h1 h2; apply.
Qed.

Lemma redmseq_correct_execseq0: forall s,
(forall st tr, redm s st tr -> exec s st tr) ->
forall tr1 tr2, redm_str s tr1 tr2 ->
execseq s tr1 tr2.
Proof.
move => s h. cofix COINDHYP. move => tr1 tr2 h1. foo h1.
- by have := execseq_nil (h _ _ H); apply.
- by have := execseq_cons _  (COINDHYP _ _ H); apply.
Qed.

Lemma Redm_sequence: forall s1 s2 st,
bisim (Redm (Sseq s1 s2) st) (sequence (Redm s2) (Redm s1 st)).
Proof.
cofix COINDHYP. move => s1 s2 st.
rewrite [Redm (Sseq s1 s2) st]trace_destr; simpl.
rewrite [Redm s1 st]trace_destr; simpl. case_eq (red s1 st).
- move => [s1' st'] h1. rewrite [sequence _ _]trace_destr; simpl.
  by have := bisim_cons _(COINDHYP _ _ _); apply.
- move => h1.  rewrite [sequence _ _]trace_destr; simpl.
  case_eq (red s2 st).
  - move => *. by apply bisim_reflexive.
  - move => *.  by apply bisim_nil.
Qed.

Lemma sequence_deterministic0: forall k1 k2,
(forall st, bisim (k1 st) (k2 st)) ->
forall tr1 tr2, bisim tr1 tr2 ->
bisim (sequence k1 tr1) (sequence k2 tr2).
Proof.
move => k1 k2 h1. cofix COINDHYP. move => tr1 tr2 h2. foo h2.
- rewrite [sequence k1 _]trace_destr.
  rewrite [sequence k2 _]trace_destr; simpl.
  have h3 := h1 st. foo h3.
  - by apply bisim_nil.
  - by have := bisim_cons _ H1; apply.
- rewrite [sequence k1 _]trace_destr; simpl.
  rewrite [sequence k2 _]trace_destr; simpl.
  by have := bisim_cons  _ (COINDHYP _ _ H); apply.
Qed.

Lemma Redm_loop_skip: forall a s st,
is_true (a st) = true ->
red s st = None ->
bisim (Redm (Sseq s (Swhile a s)) st)
 (loop (Redm s) (fun st0 => is_true (a st0)) st).
Proof.
move => a s st h1 h2. cofix COINDHYP.
rewrite [Redm _ _]trace_destr; simpl.
rewrite [loop _ _ _]trace_destr; simpl.
rewrite h1; rewrite h2; simpl.
by have := bisim_cons _ COINDHYP; apply.
Qed.

Lemma Redm_loop: forall a s,
forall st, bisim (Redm (Swhile a s) st)
 (Tcons st (loop (Redm s) (fun st0 => is_true (a st0)) st)).
Proof.
cofix COINDHYP.
have COINDHYP2: forall a s s1 st1,
bisim (Redm (Sseq s1 (Swhile a s)) st1)
(loopseq (Redm s) (fun st0 => is_true (a st0)) (Redm s1 st1)).
* cofix COINDHYP2. move => a s s1 st1. case_eq (red s1 st1).
  - move => [s1' st1'] h1. rewrite [loopseq _ _ _]trace_destr; simpl.
    rewrite [Redm _ _]trace_destr; simpl. rewrite h1. simpl.
    by have := bisim_cons _ (COINDHYP2 _ _ _ _); apply.
  - move => h1. case_eq (is_true (a st1)) => h2.
    - rewrite [Redm _ _]trace_destr; simpl. rewrite h1. rewrite h2. simpl.
      rewrite [loopseq _ _ _]trace_destr; simpl. rewrite h1.
      rewrite [loop _ _ _]trace_destr; simpl. rewrite h2.
      case_eq (red s st1).
      - move => [s' st1'] h3. rewrite [Redm _ _]trace_destr; simpl.
        rewrite h3. simpl. by have := bisim_cons _ (bisim_cons _ (COINDHYP2 _ _ _ _)); apply.
      - move => h3. rewrite [Redm _ _]trace_destr; simpl. rewrite h2; rewrite h3; simpl.
        by apply: (bisim_cons _ (bisim_cons _ (Redm_loop_skip h2 h3))).
    - rewrite [Redm _ _]trace_destr; simpl. rewrite h1; rewrite h2; simpl.
      rewrite [loopseq _ _ _]trace_destr; simpl. rewrite h1; simpl.
      rewrite [loop _ _ _]trace_destr; simpl. rewrite h2; simpl.
      rewrite [Redm _ _]trace_destr; simpl. by apply bisim_reflexive.
* move => a s st. case_eq (is_true (a st)) => h1.
  - rewrite [Redm _ _]trace_destr; simpl. rewrite h1. simpl.
    case_eq (red s st).
    - move => [s' st'] h2.
      rewrite [loop _ _ _]trace_destr; simpl. rewrite h1; rewrite h2; simpl.
      rewrite [Redm _ _]trace_destr; simpl. rewrite h2; simpl.
      by apply: (bisim_cons _ (bisim_cons _ (COINDHYP2 _ _ _ _))).
    - move => h2. by apply: (bisim_cons _ (Redm_loop_skip h1 h2)).
  - rewrite [Redm _ _]trace_destr; simpl. rewrite h1; simpl.
    rewrite [Redm _ _]trace_destr; simpl.
    rewrite [loop _ _ _]trace_destr; simpl. rewrite h1; simpl.
    by apply bisim_reflexive.
Qed.

Lemma loop_deterministic0: forall k1 k2 p,
(forall st, bisim (k1 st) (k2 st)) ->
forall st, bisim (loop k1 p st) (loop k2 p st).
Proof.
move => k1 k2 p h1.  cofix COINDHYP.
have COINDHYP2:forall tr1 tr2,
bisim tr1 tr2 -> bisim (loopseq k1 p tr1) (loopseq k2 p tr2).
- cofix COINDHYP2. move => tr1 tr2 h2. foo h2.
  - rewrite [loopseq k1 _ _]trace_destr; simpl.
    rewrite [loopseq k2 _ _]trace_destr; simpl.
    by apply: (bisim_cons _ (COINDHYP _)).
  - rewrite [loopseq k1 _ _]trace_destr; simpl.
    rewrite [loopseq k2 _ _]trace_destr; simpl.
    by apply: (bisim_cons _ (COINDHYP2 _ _ H)).
* move => st. case_eq (p st) => h2.
  - have h3 := h1 st. foo h3.
    - rewrite [loop k1 _ _]trace_destr; simpl.
      rewrite [loop k2 _ _]trace_destr; simpl.
      rewrite h2; rewrite - H; rewrite -H0.
      by apply: (bisim_cons _ (COINDHYP _)).
    - rewrite [loop k1 _ _]trace_destr; simpl.
      rewrite [loop k2 _ _]trace_destr; simpl.
      rewrite h2; rewrite - H; rewrite -H0.
      by apply: (bisim_cons _ (COINDHYP2 _ _ H1)).
  - rewrite [loop k1 _ _]trace_destr; simpl.
    rewrite [loop k2 _ _]trace_destr; simpl. rewrite h2.
    by apply bisim_nil.
Qed.

(* equivalence of the small-step functional semantics to the big-step functional semantics *)
Lemma Exec_Redm: forall s st, bisim (Exec s st) (Redm s st).
Proof.
move => s; induction s.
- move => st. rewrite [Redm _ _]trace_destr. simpl. by apply bisim_nil.
- move => st. rewrite [Redm _ _]trace_destr. simpl.
  rewrite [Redm _ _]trace_destr; simpl. by apply: (bisim_cons _ (bisim_nil _)).
- move => st. simpl. have h1 := IHs1 st.
  have h2 := sequence_deterministic0 IHs2 h1.
  have h3 := Redm_sequence s1 s2 st.
  by apply: (bisim_transitive h2 (bisim_symmetric h3)).
- move => st. case_eq (is_true (e st)) => h1.
  - rewrite [Redm _ _]trace_destr; simpl. rewrite h1; simpl.
    by apply: (bisim_cons _ (IHs1 _)).
  - rewrite [Redm _ _]trace_destr; simpl. rewrite h1; simpl.
    by apply: (bisim_cons _ (IHs2 _)).
- move => st. simpl. have h1 := Redm_loop e s st.
  have h2 := loop_deterministic0 (fun st0 => is_true (e st0)) IHs st.
  by apply: (bisim_symmetric (bisim_transitive h1 (bisim_cons _ (bisim_symmetric h2)))).
Qed.

(* the small-step relational semantics correct wrt the big-step relational semantics *)
(* by going through the functional semantics *)
Lemma redm_correct_exec: forall s st tr, redm s st tr -> exec s st tr.
Proof.
move => s st tr h1.
have h2 := Redm_correct_redm st s.
have h3 := redm_deterministic h1 h2.
have h4 := Exec_Redm s st.
have h5 := Exec_correct_exec s st.
by have := exec_insensitive h5 (bisim_transitive h4 (bisim_symmetric h3)); apply.
Qed.


(***************************************************************************
* Preservation and Progress for System-F with Subtyping - Proofs           *
* Brian Aydemir & Arthur Charguéraud, March 2007, Coq v8.1                 *
***************************************************************************)

Set Implicit Arguments.
Require Import Metatheory Fsub_Definitions Fsub_Infrastructure.

(** In parentheses are given the label of the corresponding
  lemma in the description of the POPLMark Challenge. *)

(* ********************************************************************** *)
(** * Properties of Subtyping *)

(* ********************************************************************** *)
(** Reflexivity (1) *)

Lemma sub_reflexivity : forall E T,
  okt E ->
  wft E T ->
  sub E T T .
Proof.
  introv Ok WI. poses W (type_from_wft WI). gen E.
  induction W; intros; inversions WI; eauto.
  apply_fresh* sub_all as Y.
Qed.

(* ********************************************************************** *)
(** Weakening (2) *)

Lemma sub_weakening : forall E F G S T,
   sub (E & G) S T ->
   okt (E & F & G) ->
   sub (E & F & G) S T.
Proof.
  introv Typ. gen_eq (E & G) as H. gen G.
  induction Typ; introv EQ Ok; subst; auto.
  (* case: fvar trans *)
  apply* sub_trans_tvar. apply* binds_weaken.
  (* case: all *)
  apply_fresh* sub_all as Y. apply_ih_bind* H0.
Qed.

(* ********************************************************************** *)
(** Narrowing and transitivity (3) *)

Section NarrowTrans.

Definition transitivity_on Q := forall E S T,
  sub E S Q -> sub E Q T -> sub E S T.

Hint Unfold transitivity_on.

Hint Resolve wft_narrow.

Lemma sub_narrowing_aux : forall Q F E Z P S T,
  transitivity_on Q ->
  sub (E & Z ~<: Q & F) S T ->
  sub E P Q ->
  sub (E & Z ~<: P & F) S T.
Proof.
  introv TransQ SsubT PsubQ.
  gen_eq (E & Z ~<: Q & F) as G. gen F.
  induction SsubT; introv EQ; subst.
  apply* sub_top.
  apply* sub_refl_tvar.
  case (X == Z); intros EQ; subst.
    apply (@sub_trans_tvar P); puts (@okt_narrow Q).
      apply* binds_mid.
      apply TransQ.
        do_rew* concat_assoc (apply_empty* sub_weakening).
        binds_get H. auto*.
    apply* (@sub_trans_tvar U).
    binds_cases H; auto.
  apply* sub_arrow.
  apply_fresh* sub_all as Y. apply_ih_bind* H0.
Qed.

Lemma sub_transitivity : forall Q,
  transitivity_on Q.
Proof.
  intro Q. introv SsubQ QsubT. asserts* W (type Q).
  gen E S T. gen_eq Q as Q' eq. gen Q' eq.
  induction W; intros Q' EQ E S SsubQ;
    induction SsubQ; try discriminate; inversions EQ;
      intros T QsubT; inversions QsubT;
        eauto 4 using sub_trans_tvar.
  (* case: all / top -> only needed to fix well-formedness,
     by building back what has been deconstructed too much *)
  assert (sub E (typ_all S1 S2) (typ_all T1 T2)).
    apply_fresh* sub_all as y.
  auto*.
  (* case: all / all *)
  apply_fresh sub_all as Y. auto*.
  forward~ (H0 Y) as K. apply (K (T2 open_tt_var Y)); auto.
  puts (IHW T1). apply_empty* (@sub_narrowing_aux T1).
Qed.

Lemma sub_narrowing : forall Q E F Z P S T,
  sub E P Q ->
  sub (E & Z ~<: Q & F) S T ->
  sub (E & Z ~<: P & F) S T.
Proof.
  intros.
  apply* sub_narrowing_aux.
  apply* sub_transitivity.
Qed.

End NarrowTrans.

(* ********************************************************************** *)
(** Type substitution preserves subtyping (10) *)

Lemma sub_through_subst_tt : forall Q E F Z S T P,
  sub (E & Z ~<: Q & F) S T ->
  sub E P Q ->
  sub (E & map (subst_tb Z P) F) (subst_tt Z P S) (subst_tt Z P T).
Proof.
  introv SsubT PsubQ.
  gen_eq (E & Z ~<: Q & F) as G. gen F.
  induction SsubT; introv EQ; subst; simpl subst_tt.
  apply* sub_top.
  case_var.
    apply* sub_reflexivity.
    apply* sub_reflexivity.
     inversions H0. binds_cases H3. (* wf *)
      apply* (@wft_var U).
      apply* (@wft_var (subst_tt Z P U)). unsimpl_map_bind*.
   case_var.
    apply (@sub_transitivity Q).
      apply_empty* sub_weakening.
      rewrite* <- (@subst_tt_fresh Z P Q).
        binds_get H. auto*.
        apply* (@notin_fv_wf E). apply* fresh_mid.
    apply* (@sub_trans_tvar (subst_tt Z P U)).
      rewrite* (@map_subst_tb_id E Z P).
        binds_cases H; unsimpl_map_bind*.
        apply* fresh_mid.
  apply* sub_arrow.
  apply_fresh* sub_all as X.
   unsimpl (subst_tb Z P (bind_sub T1)).
   do 2 rewrite* subst_tt_open_tt_var.
   apply_ih_map_bind* H0.
Qed.

(* ********************************************************************** *)
(** * Properties of Typing *)

(* ********************************************************************** *)
(** Weakening (5) *)

Lemma typing_weakening : forall E F G e T,
   typing (E & G) e T ->
   okt (E & F & G) ->
   typing (E & F & G) e T.
Proof.
  introv Typ. gen_eq (E & G) as H. gen G.
  induction Typ; introv EQ Ok; subst.
  apply* typing_var. apply* binds_weaken.
  apply_fresh* typing_abs as x. forward~ (H x) as K.
   apply_ih_bind (H0 x); eauto.
  apply* typing_app.
  apply_fresh* typing_tabs as X. forward~ (H X) as K.
   apply_ih_bind (H0 X); eauto.
  apply* typing_tapp. apply* sub_weakening.
  apply* typing_sub. apply* sub_weakening.
Qed.

(* ********************************************************************** *)
(** Strengthening (6) *)

Lemma sub_strengthening : forall x U E F S T,
  sub (E & x ~: U & F) S T ->
  sub (E & F) S T.
Proof.
  intros x U E F S T SsubT.
  gen_eq (E & x ~: U & F) as G. gen F.
  induction SsubT; introv EQ; subst; use wft_strengthen.
  (* case: fvar trans *)
  apply* (@sub_trans_tvar U0). binds_cases H; auto*.
  (* case: all *)
  apply_fresh* sub_all as X. apply_ih_bind* H0.
Qed.

(************************************************************************ *)
(** Preservation by Type Narrowing (7) *)

Lemma typing_narrowing : forall Q E F X P e T,
  sub E P Q ->
  typing (E & X ~<: Q & F) e T ->
  typing (E & X ~<: P & F) e T.
Proof.
  introv PsubQ Typ. gen_eq (E & X ~<: Q & F) as E'. gen F.
  induction Typ; introv EQ; subst.
  binds_cases H0; apply* typing_var.
  apply_fresh* typing_abs as y. apply_ih_bind* H0.
  apply* typing_app.
  apply_fresh* typing_tabs as Y. apply_ih_bind* H0.
  apply* typing_tapp. apply* (@sub_narrowing Q).
  apply* typing_sub. apply* (@sub_narrowing Q).
Qed.

(************************************************************************ *)
(** Preservation by Term Substitution (8) *)

Lemma typing_through_subst_ee : forall U E F x T e u,
  typing (E & x ~: U & F) e T ->
  typing E u U ->
  typing (E & F) (subst_ee x u e) T.
Proof.
  introv TypT TypU. gen_eq (E & x ~: U & F) as E'. gen F.
  induction TypT; introv EQ; subst; simpl.
  case_var.
    binds_get H0. apply_empty* typing_weakening.
    binds_cases H0; apply* typing_var.
  apply_fresh* typing_abs as y.
    rewrite* subst_ee_open_ee_var.
    apply_ih_bind* H0.
  apply* typing_app.
  apply_fresh* typing_tabs as Y.
    rewrite* subst_ee_open_te_var.
    apply_ih_bind* H0.
  apply* typing_tapp. apply* sub_strengthening.
  apply* typing_sub. apply* sub_strengthening.
Qed.

(************************************************************************ *)
(** Preservation by Type Substitution (11) *)

Lemma typing_through_subst_te : forall Q E F Z e T P,
  typing (E & Z ~<: Q & F) e T ->
  sub E P Q ->
  typing (E & map (subst_tb Z P) F) (subst_te Z P e) (subst_tt Z P T).
Proof.
  introv Typ PsubQ. gen_eq (E & Z ~<: Q & F) as G. gen F.
  induction Typ; introv EQ; subst; simpls subst_tt subst_te.
  apply* typing_var. rewrite* (@map_subst_tb_id E Z P).
   binds_cases H0; unsimpl_map_bind*. apply* fresh_mid.
  apply_fresh* typing_abs as y.
    unsimpl (subst_tb Z P (bind_typ V)).
    rewrite* subst_te_open_ee_var.
    apply_ih_map_bind* H0.
  apply* typing_app.
  apply_fresh* typing_tabs as Y.
    unsimpl (subst_tb Z P (bind_sub V)).
    rewrite* subst_te_open_te_var.
    rewrite* subst_tt_open_tt_var.
    apply_ih_map_bind* H0.
  rewrite* subst_tt_open_tt. apply* typing_tapp.
    apply* sub_through_subst_tt.
  apply* typing_sub. apply* sub_through_subst_tt.
Qed.

(* ********************************************************************** *)
(** * Preservation *)

(* ********************************************************************** *)
(** Inversions for Typing (13) *)

Lemma typing_inv_abs : forall E S1 e1 T,
  typing E (trm_abs S1 e1) T ->
  forall U1 U2, sub E T (typ_arrow U1 U2) ->
     sub E U1 S1
  /\ exists S2, exists L, forall x, x \notin L ->
     typing (E & x ~: S1) (e1 open_ee_var x) S2 /\ sub E S2 U2.
Proof.
  introv Typ. gen_eq (trm_abs S1 e1) as e. gen S1 e1.
  induction Typ; intros S1 b1 EQ U1 U2 Sub; inversions EQ.
  inversions* Sub. use (@sub_transitivity T).
Qed.

Lemma typing_inv_tabs : forall E S1 e1 T,
  typing E (trm_tabs S1 e1) T ->
  forall U1 U2, sub E T (typ_all U1 U2) ->
     sub E U1 S1
  /\ exists S2, exists L, forall X, X \notin L ->
     typing (E & X ~<: U1) (e1 open_te_var X) (S2 open_tt_var X)
     /\ sub (E & X ~<: U1) (S2 open_tt_var X) (U2 open_tt_var X).
Proof.
  intros E S1 e1 T H. gen_eq (trm_tabs S1 e1) as e. gen S1 e1.
  induction H; intros S1 b EQ U1 U2 Sub; inversion EQ.
  inversions Sub. splits. auto.
   exists T1. let L1 := gather_vars in exists L1.
   intros Y Fr. splits.
    apply_empty* (@typing_narrowing S1). auto.
  use (@sub_transitivity T).
Qed.

(* ********************************************************************** *)
(** Preservation Result (20) *)

Lemma preservation_result : preservation.
Proof.
  introv Typ. gen e'. induction Typ; introv Red;
   try solve [ inversion Red ].
  (* case: app *)
  inversions Red; try solve [ apply* typing_app ].
  destructi (typing_inv_abs Typ1 (U1:=T1) (U2:=T2)) as [P1 [S2 [L P2]]].
    apply* sub_reflexivity.
    pick_fresh X. forward~ (P2 X) as K. destruct K.
     rewrite* (@subst_ee_intro X).
     apply_empty (@typing_through_subst_ee V).
       apply* (@typing_sub S2). apply_empty* sub_weakening.
       auto*.
  (* case: tapp *)
  inversions Red; try solve [ apply* typing_tapp ].
  destructi (typing_inv_tabs Typ (U1:=T1) (U2:=T2)) as [P1 [S2 [L P2]]].
    apply* sub_reflexivity.
    pick_fresh X. forward~ (P2 X) as K. destruct K.
     rewrite* (@subst_te_intro X).
     rewrite* (@subst_tt_intro X).
     unsimpl (E & map (subst_tb X T) empty).
     apply* (@typing_through_subst_te T1).
  (* case sub *)
  apply* typing_sub.
Qed.

(* ********************************************************************** *)
(** * Progress *)

(* ********************************************************************** *)
(** Canonical Forms (14) *)

Lemma canonical_form_abs : forall t U1 U2,
  value t -> typing empty t (typ_arrow U1 U2) ->
  exists V, exists e1, t = trm_abs V e1.
Proof.
  introv Val Typ. gen_eq (@empty bind) as E.
  gen_eq (typ_arrow U1 U2) as T. gen U1 U2.
  induction Typ; introv EQT EQE;
   try solve [ inversion Val | inversion EQT | eauto ].
    subst. inversion H. inversion H0. auto*.
Qed.

Lemma canonical_form_tabs : forall t U1 U2,
  value t -> typing empty t (typ_all U1 U2) ->
  exists V, exists e1, t = trm_tabs V e1.
Proof.
  introv Val Typ. gen_eq (@empty bind) as E.
  gen_eq (typ_all U1 U2) as T. gen U1 U2.
  induction Typ; introv EQT EQE;
   try solve [ inversion Val | inversion EQT | eauto ].
    subst. inversion H. inversion H0. auto*.
Qed.

(* ********************************************************************** *)
(** Progress Result (16) *)

Lemma progress_result : progress.
Proof.
  introv Typ. gen_eq (@empty bind) as E. poses Typ' Typ.
  induction Typ; intros EQ; subst.
  (* case: var *)
  inversion H0.
  (* case: abs *)
  left*.
  (* case: app *)
  right. destruct* IHTyp1 as [Val1 | [e1' Rede1']].
    destruct* IHTyp2 as [Val2 | [e2' Rede2']].
      destruct (canonical_form_abs Val1 Typ1) as [S [e3 EQ]].
        subst. exists* (open_ee e3 e2).
  (* case: tabs *)
  left*.
  (* case: tapp *)
  right. destruct* IHTyp as [Val1 | [e1' Rede1']].
    destruct (canonical_form_tabs Val1 Typ) as [S [e3 EQ]].
      subst. exists* (open_te e3 T).
      exists* (trm_tapp e1' T).
  (* case: sub *)
  auto*.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall O E Eprime A B C D X Bprimeprime Bprime Dprime : Universe, ((wd_ C O /\ (wd_ A O /\ (wd_ B O /\ (wd_ D O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ Eprime C /\ (wd_ Bprime O /\ (wd_ X O /\ (wd_ E Bprimeprime /\ (wd_ C Bprime /\ (wd_ B Bprimeprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ O E D /\ (col_ O E X /\ (col_ O Eprime Bprimeprime /\ (col_ O Eprime Bprime /\ col_ O Eprime Dprime)))))))))))))))))))) -> col_ O C X)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B X Y T PX PY Bprime Cprime : Universe, ((wd_ A B /\ (wd_ A T /\ (wd_ PX A /\ (wd_ PY A /\ (wd_ A Cprime /\ (wd_ Y PY /\ (wd_ PY B /\ (wd_ PX B /\ (wd_ T B /\ (wd_ T Y /\ (wd_ A Y /\ (wd_ T X /\ (wd_ A X /\ (wd_ B Y /\ (wd_ B X /\ (wd_ PY Cprime /\ (wd_ B Bprime /\ (wd_ A Bprime /\ (wd_ X PX /\ (wd_ B Cprime /\ (wd_ PX Cprime /\ (col_ PX A T /\ (col_ PY A T /\ (col_ A PX PY /\ (col_ A Y PY /\ (col_ B Y PY /\ (col_ PY A Cprime /\ col_ B A Bprime))))))))))))))))))))))))))) -> col_ A B Y)).
Proof.
  time tac.
Qed.

End FOFProblem.