Require Import Term_Defs OptMonad_Coq BS Preamble.
Require Import StructTactics Defs.

Require Import Lia Coq.Program.Tactics.
Require Import List.
Import List.ListNotations.

(** * Annotated Terms

    Annotated terms are used to ensure that each distinct event has a
    distinct natural number.  To do so, each term is annotated by a
    pair of numbers called a range.  Let [(i, k)] be the label for
    term [t].  The labels will be chosen to have the property such
    that for each event in the set of events associated with term [t],
    its number [j] will be in the range [i <= j < k].  *)

Definition Range: Set := nat * nat.

Inductive AnnoTerm: Set :=
| aasp: Range -> ASP -> AnnoTerm
| aatt: Range -> Plc -> AnnoTerm -> AnnoTerm
| alseq: Range -> AnnoTerm -> AnnoTerm -> AnnoTerm
| abseq: Range -> Split -> AnnoTerm -> AnnoTerm -> AnnoTerm
| abpar: Range -> Split -> AnnoTerm -> AnnoTerm -> AnnoTerm.

(* Evidence Type size *)
Fixpoint esize t :=
  match t with
  | aasp _ _ => 1
  | aatt _ _ t1 => 2 + esize t1
  | alseq _ t1 t2 => esize t1 + esize t2
  | abseq _ _ t1 t2 => 2 + esize t1 + esize t2
  | abpar _ _ t1 t2 => 2 + esize t1 + esize t2
  end.

(* Extract Range from each annotated term *)
Definition range x :=
  match x with
  | aasp r _ => r
  | aatt r _ _ => r
  | alseq r _ _ => r
  | abseq r _ _ _ => r
  | abpar r _ _ _ => r
  end.

(*
Inductive AnnoTermPar: Set :=
| aasp_par: ASP -> AnnoTermPar
| aatt_par: Plc -> Term -> AnnoTermPar
| alseq_par: AnnoTermPar -> AnnoTermPar -> AnnoTermPar
| abseq_par: Split -> AnnoTermPar -> AnnoTermPar -> AnnoTermPar
| abpar_par: Loc -> Split -> AnnoTermPar -> Term -> AnnoTermPar.

Fixpoint unannoPar (t:AnnoTermPar) : Term :=
  match t with
  | aasp_par a => asp a
  | aatt_par p t => att p t
  | alseq_par a1 a2 => lseq (unannoPar a1) (unannoPar a2)
  | abseq_par spl a1 a2 => bseq spl (unannoPar a1) (unannoPar a2)
  | abpar_par _ spl a1 a2 => bpar spl (unannoPar a1) a2
  end.

Fixpoint anno_par (t:Term) (loc:Loc) : (Loc * AnnoTermPar)  :=
  match t with
  | asp a => (loc, aasp_par a)
  | att p t' => (loc, aatt_par p t')

  | lseq t1 t2 =>
    let '(loc', t1') := anno_par t1 loc in
    let '(loc'', t2') := anno_par t2 loc' in

    (loc'', alseq_par t1' t2')

  | bseq spl t1 t2 =>
    let '(loc', t1') := anno_par t1 loc in
    let '(loc'', t2') := anno_par t2 loc' in

    (loc'', abseq_par spl t1' t2')

  | bpar spl t1 t2 =>
    let '(loc', t1') := anno_par t1 (S loc) in

    (loc', abpar_par loc spl t1' t2)
  end.

Definition peel_loc (ls:list Loc) : Opt (Loc * list Loc) :=
  match ls with
  | bs :: ls' => ret (bs, ls')
  | _ => failm
  end.

Fixpoint anno_par_list' (t:Term) (ls:list Loc) : Opt (list Loc * AnnoTermPar) :=
  match t with
  | asp a => ret (ls, aasp_par a)
  | att p t' => ret (ls, aatt_par p t')
  | lseq t1 t2 =>
    '(ls', t1') <- anno_par_list' t1 ls ;;
    '(ls'', t2') <- anno_par_list' t2 ls' ;;
    ret (ls'', alseq_par t1' t2')
  | bseq spl t1 t2 =>
    '(ls', t1') <- anno_par_list' t1 ls ;;
    '(ls'', t2') <- anno_par_list' t2 ls' ;;
    ret (ls'', abseq_par spl t1' t2')
  | bpar spl t1 t2 =>
    '(loc, ls') <- peel_loc ls ;;
    '(ls'', t1') <- anno_par_list' t1 ls' ;;
    ret (ls'', abpar_par loc spl t1' t2)
  end.

Definition anno_par_list (t:Term) (ls:list Loc) : Opt AnnoTermPar :=
  '(ls', t') <- anno_par_list' t ls ;;
  ret t'.

Set Nested Proofs Allowed.

Lemma peel_loc_fact: forall ls ls' loc,
    peel_loc ls = Some (loc, ls') ->
    length ls' = length ls - 1.
Proof.
  intros.
  generalizeEverythingElse ls.
  induction ls; intros; ff.
  unfold ret in *. inversion H.
  subst.
  lia.
Defined.

Lemma par_list_helper: forall t1 t1' ls ls',
    anno_par_list' t1 ls = Some (ls', t1') ->
    length ls' = length ls - top_level_thread_count t1.
Proof.
  intros.
  generalizeEverythingElse t1.
  induction t1; intros.
  -
    ff.
    unfold ret in *.
    ff.
    lia.
  -
    ff.
    unfold ret in *.
    ff.
    lia.
  -
    ff.
    unfold bind in *.
    unfold ret in *.
    ff.
    find_eapply_hyp_hyp.
    find_eapply_hyp_hyp.
    lia.
  -
    ff.
    unfold bind in *.
    unfold ret in *.
    ff.
    find_eapply_hyp_hyp.
    find_eapply_hyp_hyp.
    lia.
  -
    ff.
    unfold bind in *.
    unfold ret in *.
    ff.
    find_eapply_hyp_hyp.
    rewrite Heqo0.
    assert (length l0 = length ls - 1).
    {
      eapply peel_loc_fact.
      eauto.
    }
    lia.
Defined.

Lemma peel_loc_fact2: forall ls,
    length ls >= 1 ->
    exists res, peel_loc ls = Some res.
Proof.
  intros.
  generalizeEverythingElse ls.
  induction ls; intros.
  -
    ff.
  -
    ff.
    unfold ret.
    eauto.
Defined.

Lemma anno_par_list_some : forall ls t,
  length ls >= (top_level_thread_count t) ->
  exists t', anno_par_list t ls = Some t'.
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros.
  -
    ff.
    eauto.
  -
    ff.
    eauto.
  -
    ff.
    unfold anno_par_list.
    cbn.
    destruct (anno_par_list' t1 ls) eqn:hi.
    unfold bind.
    ff.
    unfold ret.
    eauto.

    assert (length l >= top_level_thread_count t2).
    {
      assert (length ls >= top_level_thread_count t2) by lia.
      assert (length l = length ls - (top_level_thread_count t1)).
      {

        eapply par_list_helper; eauto.
      }
      rewrite H1.
      lia.
    }

    find_eapply_hyp_hyp.
    destruct_conjs.
    unfold anno_par_list in H1.
    unfold bind in H1.
    ff.

    assert (length ls >= top_level_thread_count t1) by lia.
    find_eapply_hyp_hyp.
    destruct_conjs.
    unfold anno_par_list in H1.
    unfold bind in H1.
    ff.
  -
    ff.
    unfold anno_par_list.
    cbn.
    destruct (anno_par_list' t1 ls) eqn:hi.
    unfold bind.
    ff.
    unfold ret.
    eauto.

    assert (length l >= top_level_thread_count t2).
    {
      assert (length ls >= top_level_thread_count t2) by lia.
      assert (length l = length ls - (top_level_thread_count t1)).
      {

        eapply par_list_helper; eauto.
      }
      rewrite H1.
      lia.
    }

    find_eapply_hyp_hyp.
    destruct_conjs.
    unfold anno_par_list in H1.
    unfold bind in H1.
    ff.

    assert (length ls >= top_level_thread_count t1) by lia.
    find_eapply_hyp_hyp.
    destruct_conjs.
    unfold anno_par_list in H1.
    unfold bind in H1.
    ff.
  -
    ff.
    unfold anno_par_list.
    cbn.
    destruct (anno_par_list' t1 ls) eqn:hi.
    unfold bind.
    ff.
    unfold ret.
    eauto.

    assert (length l0 >= top_level_thread_count t1).
    {
      assert (length l0 = length ls - 1).
      {
        eapply peel_loc_fact; eauto.
      }
      lia.
    }
    find_eapply_hyp_hyp.
    destruct_conjs.
    unfold anno_par_list in H1.
    unfold bind in H1. ff.

    assert (length ls >= 1) by lia.

    edestruct peel_loc_fact2.
    eassumption.
    rewrite H1 in *.
    ff.

    unfold bind in *.
    ff.
    unfold ret in *; ff.
    eauto.

    assert (length l0 >= top_level_thread_count t1).
    {
      assert (length l0 = length ls - 1).
      {
        eapply peel_loc_fact; eauto.
      }
      lia.

    }
    find_eapply_hyp_hyp.
    destruct_conjs.
    unfold anno_par_list in H1.
    unfold bind in H1. ff.

     assert (length ls >= 1) by lia.

    edestruct peel_loc_fact2.
    eassumption.
    rewrite H1 in *.
    ff.
Defined.

Definition annotated_par (x:Term) :=
  snd (anno_par x 0).
*)

Inductive term_sub : Term -> Term -> Prop :=
| termsub_refl_annt: forall t: Term, term_sub t t
| aatt_sub_annt: forall t t' p,
    term_sub t' t ->
    term_sub t' (att p t)
| alseq_subl_annt: forall t' t1 t2,
    term_sub t' t1 ->
    term_sub t' (lseq t1 t2)
| alseq_subr_annt: forall t' t1 t2,
    term_sub t' t2 ->
    term_sub t' (lseq t1 t2)
| abseq_subl_annt: forall t' t1 t2 s,
    term_sub t' t1 ->
    term_sub t' (bseq s t1 t2)
| abseq_subr_annt: forall t' t1 t2 s,
    term_sub t' t2 ->
    term_sub t' (bseq s t1 t2)
| abpar_subl_annt: forall t' t1 t2 s,
    term_sub t' t1 ->
    term_sub t' (bpar s t1 t2)
| abpar_subr_annt: forall t' t1 t2 s,
    term_sub t' t2 ->
    term_sub t' (bpar s t1 t2).
Hint Constructors term_sub : core.

Lemma termsub_transitive: forall t t' t'',
    term_sub t t' ->
    term_sub t' t'' ->
    term_sub t t''.
Proof.
  generalizeEverythingElse t''.
  induction t'';
    intros H H0; ff.
    (* try (invc H0; eauto). *)
Defined.

(*

Lemma nullify_no_none_nones_seq: forall t t' t1 t2 sp,
    nullify_branchesP t t' ->
    term_sub (bseq sp t1 t2) t' ->
    sp = (ALL,ALL).
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros.
  -
    destruct a; ff; invc H; ff.
  -
    invc H; ff.
    invc H0.

    eapply IHt.
    2: { eassumption. }
    econstructor.
    eauto.
  -
    invc H; ff.
    invc H0.
    + (* t1 term_sub case *)
      eapply IHt1.
      2: { eassumption. }
      econstructor; eauto.
    +
      eapply IHt2.
      2: { eassumption. }
      econstructor; eauto.
  -
    invc H; ff.
    invc H0; ff.
    eapply IHt1.
    2: { eassumption. }
    econstructor; eauto.

    eapply IHt2.
    2: { eassumption. }
    econstructor; eauto.

    invc H0; ff.

     eapply IHt1.
    2: { eassumption. }
    econstructor; eauto.

    invc H2.
    invc H1.

     eapply IHt2.
    2: { eassumption. }
    econstructor; eauto.

    invc H0; ff.

    invc H2.
    invc H1.

    eapply IHt1.
    2: { eassumption. }
    econstructor; eauto.

     eapply IHt2.
    2: { eassumption. }
    econstructor; eauto.

    invc H0; ff.

    invc H2.
    invc H1.

    eapply IHt1.
    2: { eassumption. }
    econstructor; eauto.

    invc H2.
    invc H1.

     eapply IHt2.
    2: { eassumption. }
    econstructor; eauto.
  -
        invc H; ff.
    invc H0; ff.
    eapply IHt1.
    2: { eassumption. }
    econstructor; eauto.

    eapply IHt2.
    2: { eassumption. }
    econstructor; eauto.

    invc H0; ff.

     eapply IHt1.
    2: { eassumption. }
    econstructor; eauto.

    invc H2.
    invc H1.

     eapply IHt2.
    2: { eassumption. }
    econstructor; eauto.

    invc H0; ff.

    invc H2.
    invc H1.

    eapply IHt1.
    2: { eassumption. }
    econstructor; eauto.

     eapply IHt2.
    2: { eassumption. }
    econstructor; eauto.

    invc H0; ff.

    invc H2.
    invc H1.

    eapply IHt1.
    2: { eassumption. }
    econstructor; eauto.

    invc H2.
    invc H1.

     eapply IHt2.
    2: { eassumption. }
    econstructor; eauto.
Qed.

Lemma nullify_no_none_nones_par: forall t t' t1 t2 sp,
    nullify_branchesP t t' ->
    term_sub (bpar sp t1 t2) t' ->
    sp = (ALL,ALL).
Proof.
    intros.
  generalizeEverythingElse t.
  induction t; intros.
  -
    destruct a; ff; invc H; ff.
  -
    invc H; ff.
    invc H0.

    eapply IHt.
    2: { eassumption. }
    econstructor.
    eauto.
  -
    invc H; ff.
    invc H0.
    + (* t1 term_sub case *)
      eapply IHt1.
      2: { eassumption. }
      econstructor; eauto.
    +
      eapply IHt2.
      2: { eassumption. }
      econstructor; eauto.
  -
    invc H; ff.
    invc H0; ff.
    eapply IHt1.
    2: { eassumption. }
    econstructor; eauto.

    eapply IHt2.
    2: { eassumption. }
    econstructor; eauto.

    invc H0; ff.

     eapply IHt1.
    2: { eassumption. }
    econstructor; eauto.

    invc H2.
    invc H1.

     eapply IHt2.
    2: { eassumption. }
    econstructor; eauto.

    invc H0; ff.

    invc H2.
    invc H1.

    eapply IHt1.
    2: { eassumption. }
    econstructor; eauto.

     eapply IHt2.
    2: { eassumption. }
    econstructor; eauto.

    invc H0; ff.

    invc H2.
    invc H1.

    eapply IHt1.
    2: { eassumption. }
    econstructor; eauto.

    invc H2.
    invc H1.

     eapply IHt2.
    2: { eassumption. }
    econstructor; eauto.
  -
        invc H; ff.
    invc H0; ff.
    eapply IHt1.
    2: { eassumption. }
    econstructor; eauto.

    eapply IHt2.
    2: { eassumption. }
    econstructor; eauto.

    invc H0; ff.

     eapply IHt1.
    2: { eassumption. }
    econstructor; eauto.

    invc H2.
    invc H1.

     eapply IHt2.
    2: { eassumption. }
    econstructor; eauto.

    invc H0; ff.

    invc H2.
    invc H1.

    eapply IHt1.
    2: { eassumption. }
    econstructor; eauto.

     eapply IHt2.
    2: { eassumption. }
    econstructor; eauto.

    invc H0; ff.

    invc H2.
    invc H1.

    eapply IHt1.
    2: { eassumption. }
    econstructor; eauto.

    invc H2.
    invc H1.

     eapply IHt2.
    2: { eassumption. }
    econstructor; eauto.
Qed.

Lemma nullify_no_none_seq_contra: forall t t' t1 t2 sp1 sp2,
  nullify_branchesP t t' ->
  term_sub (bseq (sp1,sp2) t1 t2) t' ->
  ((sp1 = NONE) \/ (sp2 = NONE)) ->
  False.
Proof.
  intros.
  invc H1.
  -
    assert ((NONE,sp2) = (ALL,ALL)).
    {
      eapply nullify_no_none_nones_seq; eauto.
    }
    invc H1.
  -
    assert ((sp1,NONE) = (ALL,ALL)).
    {
      eapply nullify_no_none_nones_seq; eauto.
    }
    invc H1.
Qed.

Lemma nullify_no_none_par_contra: forall t t' t1 t2 sp1 sp2,
  nullify_branchesP t t' ->
  term_sub (bpar (sp1,sp2) t1 t2) t' ->
  ((sp1 = NONE) \/ (sp2 = NONE)) ->
  False.
Proof.
  intros.
  invc H1.
  -
    assert ((NONE,sp2) = (ALL,ALL)).
    {
      eapply nullify_no_none_nones_par; eauto.
    }
    invc H1.
  -
    assert ((sp1,NONE) = (ALL,ALL)).
    {
      eapply nullify_no_none_nones_par; eauto.
    }
    invc H1.
Qed.
*)

(*
(** This function annotates a term.  It feeds a natural number
    throughout the computation so as to ensure each event has a unique
    natural number. *) *)

Fixpoint anno (t: Term) (i:nat) : (nat * AnnoTerm) :=
  match t with
  | asp x => (S i, (aasp (i, S i) x))

  | att p x =>
    let '(j,a) := anno x (S i)  in
    (S j, aatt (i, S j) p a)

  | lseq x y =>
    let '(j,a) := anno x i in
    let '(k,bt) := anno y j in
    (k, alseq (i, k) a bt)

  | bseq s x y =>
    let '(j,a) := anno x (S i) in
    let '(k,b) := anno y j in
    (S k, abseq (i, S k) s a b)

  | bpar s x y =>
    let '(j,a) := anno x (S i) in
    let '(k,b) := anno y j in
    (S k, abpar (i, S k) s a b)
  end.

Definition annotated x :=
  snd (anno x 0).

Fixpoint unanno a :=
  match a with
  | aasp _ a => asp a
  | aatt _ p t => att p (unanno t)
  | alseq _ a1 a2 => lseq (unanno a1) (unanno a2)
  | abseq _ spl a1 a2 => bseq spl (unanno a1) (unanno a2)
  | abpar _ spl a1 a2 => bpar spl (unanno a1) (unanno a2)
  end.

Lemma anno_unanno: forall t i,
    unanno (snd (anno t i)) = t.
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros.
  -
    destruct a; ff.
  -
    ff.
    erewrite <- IHt.
    jkjke.
  -
    ff.
    erewrite <- IHt1.
    erewrite <- IHt2.
    jkjke.
    jkjke.
  -
    ff.
    erewrite <- IHt1.
    erewrite <- IHt2.
    jkjke.
    jkjke.
  -
    ff.
    erewrite <- IHt1.
    erewrite <- IHt2.
    jkjke.
    jkjke.
Defined.

(*

Lemma anno_unanno_par: forall a l l' annt,
    anno_par a l = (l', annt) ->
    unannoPar annt = a.
Proof.
  intros.
  generalizeEverythingElse a.
  induction a; intros.
  -
    ff.
  -
    ff.
  -
    ff.
    assert (unannoPar a = a1) by eauto.
    assert (unannoPar a0 = a2) by eauto.
    congruence.
  -
    ff.
    assert (unannoPar a = a1) by eauto.
    assert (unannoPar a0 = a2) by eauto.
    congruence.
  -
    ff.
    assert (unannoPar a = a1) by eauto.
    congruence.
Defined.

Lemma anno_unanno_par_list': forall a l l' annt,
    anno_par_list' a l = Some (l', annt) ->
    unannoPar annt = a.
Proof.
  intros.
  generalizeEverythingElse a.
  induction a; intros.
  -
    ff.
  -
    ff.
  -
    ff.
    unfold bind in *.
    unfold ret in *.
    ff.
    assert (unannoPar a = a1) by eauto.
    assert (unannoPar a0 = a2) by eauto.
    congruence.
  -
    ff.
    unfold bind in *.
    unfold ret in *.
    ff.
    assert (unannoPar a = a1) by eauto.
    assert (unannoPar a0 = a2) by eauto.
    congruence.
  -
    ff.
    unfold bind in *.
    unfold ret in *.
    ff.
    assert (unannoPar a = a1) by eauto.
    congruence.
Defined.

Lemma anno_unanno_par_list: forall a l annt,
    anno_par_list a l = Some annt ->
    unannoPar annt = a.
Proof.
  intros.
  unfold anno_par_list in *.
  unfold bind in *.
  unfold ret in *.
  ff.
  eapply anno_unanno_par_list'.
  eassumption.
Defined.
*)

Inductive annoP: AnnoTerm -> Term -> Prop :=
| annoP_c: forall anno_term t,
    (exists n n', anno t n = (n',anno_term)) -> (* anno_term = snd (anno t n)) -> *)
    annoP anno_term t.

Inductive annoP_indexed': AnnoTerm -> Term -> nat -> Prop :=
| annoP_c_i': forall anno_term t n,
    (exists n', anno t n = (n', anno_term)) -> (*anno_term = snd (anno t n) -> *)
    annoP_indexed' anno_term t n.

Inductive annoP_indexed: AnnoTerm -> Term -> nat -> nat ->  Prop :=
| annoP_c_i: forall anno_term t n n',
    (*(exists n', anno t n = (n', anno_term)) -> (*anno_term = snd (anno t n) -> *) *)
    anno t n = (n', anno_term) ->
    annoP_indexed anno_term t n n'.

(*
Inductive anno_parP (*anno_par_listP*): AnnoTermPar -> Term -> Prop :=
| anno_parP_c: forall par_term t,
    (exists ls ls', anno_par_list' t ls = Some (ls', par_term)) -> (*par_term = snd (anno_par t loc)) -> *)
    (*anno_par_listP*) anno_parP par_term t.

Inductive anno_parPloc: AnnoTermPar -> Term -> list Loc -> Prop :=
| anno_parP_cloc: forall par_term t ls,
    (exists ls', anno_par_list' t ls = Some (ls', par_term)) -> (*par_term = snd (anno_par t loc) -> *)
    anno_parPloc par_term t ls.
*)

(*
Inductive anno_parP: AnnoTermPar -> Term -> Prop :=
| anno_parP_c: forall par_term t,
    (exists loc loc', anno_par t loc = (loc', par_term)) -> (*par_term = snd (anno_par t loc)) -> *)
    anno_parP par_term t.

Inductive anno_parPloc: AnnoTermPar -> Term -> Loc -> Prop :=
| anno_parP_cloc: forall par_term t loc,
    (exists loc', anno_par t loc = (loc', par_term)) -> (*par_term = snd (anno_par t loc) -> *)
    anno_parPloc par_term t loc.

Inductive anno_par_listP: AnnoTermPar -> Term -> Prop :=
| anno_par_listP_c: forall par_term t,
    (exists ls ls', anno_par_list' t ls = Some (ls', par_term)) -> (*par_term = snd (anno_par t loc)) -> *)
    anno_par_listP par_term t.

Inductive anno_par_listPls: AnnoTermPar -> Term -> list Loc -> Prop :=
| anno_par_listP_cloc: forall par_term t ls,
    (exists ls', anno_par_list' t ls = Some (ls', par_term)) -> (*par_term = snd (anno_par t loc) -> *)
    anno_par_listPls par_term t ls.
*)

(*

Lemma nolist_list_same_annopar: forall t annt,
  anno_parP annt t ->
  anno_par_listP annt t.
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros.
  -
    invc H.
    destruct_conjs.
    econstructor.
    destruct a; ff; eauto.
  -
    invc H.
    destruct_conjs.
    econstructor.
    ff.
    eauto.
  -
    invc H.
    destruct_conjs.
    ff.
    assert (anno_parP a t1).
    {
      econstructor; eauto.
    }
    find_eapply_hyp_hyp.

    assert (anno_parP a0 t2).
    {
      econstructor; eauto.
    }
    find_eapply_hyp_hyp.

    invc H1; invc H2.
    destruct_conjs.

    (*
    econstructor.
    exists H3. eexists.

    ff.

    unfold bind.
    unfold ret.
    find_rewrite.
    find_rewrite.

    repeat eexists.
    ff.
    rewrite H6 in *.
    ff.
    unfold an
    ff.
    eauto.
    ff.

    eauto.
  -
    invc H.
    destruct_conjs.
    econstructor.
    eauto.
  - invc H.
    destruct_conjs.
    econstructor.
    eauto.
Defined.
*)

Lemma list_nolist_same_annopar: forall t annt,
  anno_par_listP annt t ->
  anno_parP annt t.
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros;
    invc H;
    destruct_conjs; econstructor; eauto.
Defined.

*)

(** This predicate determines if an annotated term is well formed,
    that is if its ranges correctly capture the relations between a
    term and its associated events. *)

(*
Lemma unique_req_events (t:AnnoTerm) : forall p i i0 p1 p2 q q0 t0 t1,
       events t p (req i  loc p1 q  t0) ->
    not (events t p (req i0 loc p2 q0 t1)).
 *)

(** Eval for annotated terms. *)

Fixpoint aeval t p e :=
  match t with
  | aasp _ x => eval (asp x) p e
  | aatt _ q x => aeval x q e
  | alseq _ t1 t2 => aeval t2 p (aeval t1 p e)
  | abseq _ s t1 t2 => ss (aeval t1 p ((splitEv_T_l s e)))
                         (aeval t2 p ((splitEv_T_r s e)))
  | abpar _ s t1 t2 => ss (aeval t1 p ((splitEv_T_l s e)))
                         (aeval t2 p ((splitEv_T_r s e)))
  end.

Lemma eval_aeval:
  forall t p e i,
    eval t p e = aeval (snd (anno t i)) p e.
Proof.
  induction t; intros; simpl; auto;
    repeat expand_let_pairs; simpl;
      try (repeat jkjk; auto;congruence);
      try (repeat jkjk'; auto).
Defined.

Inductive well_formed_r_annt: AnnoTerm -> Prop :=
| wf_asp_r_annt: forall r x,
    snd r = S (fst r) ->
    well_formed_r_annt (aasp r x)
| wf_att_r_annt: forall r p x,
    well_formed_r_annt x ->
    S (fst r) = fst (range x) ->
    snd r = S (snd (range x)) ->
    Nat.pred (snd r) > fst r ->
    well_formed_r_annt (aatt r p x)

| wf_lseq_r_annt: forall r x y,
    well_formed_r_annt x -> well_formed_r_annt y ->
    fst r = fst (range x) ->
    snd (range x) = fst (range y) ->
    snd r = snd (range y) ->
    well_formed_r_annt (alseq r x y)
| wf_bseq_r_annt: forall r s x y,
    well_formed_r_annt x -> well_formed_r_annt y ->
    S (fst r) = fst (range x) ->
    snd (range x) = fst (range y) ->
    snd r = S (snd (range y)) ->
    well_formed_r_annt (abseq r s x y)
| wf_bpar_r_annt: forall r s x y,
    well_formed_r_annt x -> well_formed_r_annt y ->
    S (fst r) = fst (range x) ->
    snd (range x) = fst (range y) ->
    (snd r) = S (snd (range y)) ->
    (*fst (range y) > fst (range x) -> *)
    well_formed_r_annt (abpar r s x y).
Hint Constructors well_formed_r_annt : core.

Ltac afa :=
  match goal with
  | [H : forall _, _, H2: Term, H3: nat |- _] => pose_new_proof (H H2 H3)
  end.

Ltac afa' :=
  match goal with
  | [H : forall _, _, H2: Term, H3: nat |- _] => pose_new_proof (H H2 (S H3))
  end.

Ltac afa'' :=
  match goal with
  | [H : forall _, _, H2: Term, H3: nat, H4:nat, H5: AnnoTerm |- _] =>
    pose_new_proof (H H2 (H3)(H4) H5)
  end.

Ltac same_index :=
  match goal with
  | [H: anno ?t _ = (?n, _),
        H': anno ?t _ = (?n', _) |- _] =>
    assert_new_proof_by (n = n') eauto
  end.

Lemma same_anno_range: forall t i a b n n',
    anno t i = (n,a) ->
    anno t i = (n',b) ->
    n = n'.
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros;
    try destruct a;
    ff.
Defined.

Lemma anno_mono : forall (t:Term) (i j:nat) (t':AnnoTerm),
  anno t i = (j,t') ->
  j > i.
Proof.
  induction t; intros; (*i j t' ls b H; *)
    ff;
    repeat find_apply_hyp_hyp;
    lia.
Defined.
Hint Resolve anno_mono : core.

Lemma anno_range:
  forall x i j t',
     anno x i = (j,t') ->
    range (t') = (i, j).
Proof.
  induction x; intros; ff.
Defined.

Ltac haha :=
  let asdff := eapply anno_mono; eauto in
  match goal with
  | [H: anno _ ?x = (?y,_) |- _] => assert_new_proof_by (y > x) (asdff)
  end.

Ltac hehe :=
  match goal with
  | [H: anno ?x ?y = (_,_) |- _] => pose_new_proof (anno_range x y)
  end.

Ltac hehe' :=
  match goal with
  | [x: Term, y:nat |- _] => pose_new_proof (anno_range x (S y))
  end.

Ltac hehe'' :=
  match goal with
  | [x: Term, y:nat |- _] => pose_new_proof (anno_range x y)
  end.

Ltac do_list_empty :=
  match goal with
    [H: length ?ls = 0 |- _] =>
    assert_new_proof_by (ls = []) ltac:(destruct ls; solve_by_inversion)
  end.

Lemma anno_well_formed_r:
  forall t i j t',
    anno t i = (j, t') ->
    well_formed_r_annt t'.
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros.
  -
    destruct a;
      ff.
  -
    ff.
    +
      econstructor.
      eauto.
      simpl.
      erewrite anno_range.
      2: {
        eassumption.
      }
      tauto.

      simpl.
      erewrite anno_range.
      2: {
        eassumption.
      }
      tauto.

      simpl.
      assert (n > S i) by (eapply anno_mono; eauto).
      lia.
  -
    ff.
    econstructor.
    eauto.
    eauto.

    simpl.
    erewrite anno_range.
    2: {
        eassumption.
      }
    tauto.

    simpl.
    erewrite anno_range.
    2: {
        eassumption.
      }
    erewrite anno_range.
    2: {
        eassumption.
      }
    tauto.

    simpl.
    erewrite anno_range.
    2: {
        eassumption.
      }
    tauto.

  -
    ff.
    econstructor.
    eauto.
    eauto.

     simpl.
      erewrite anno_range.
      2: {
        eassumption.
      }
      tauto.

      simpl.
      erewrite anno_range.
      2: {
        eassumption.
      }
      erewrite anno_range.
      2: {
        eassumption.
      }
      tauto.

      simpl.
      erewrite anno_range.
      2: {
        eassumption.
      }
      tauto.

  -
    ff.
    econstructor.
    eauto.
    eauto.

     simpl.
      erewrite anno_range.
      2: {
        eassumption.
      }
      tauto.

      simpl.
      erewrite anno_range.
      2: {
        eassumption.
      }
      erewrite anno_range.
      2: {
        eassumption.
      }

      tauto.

      simpl.
      erewrite anno_range.
      2: {
        eassumption.
      }
      tauto.
Defined.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Import Arith.
From IntMap Require Import Allmaps.
Require Import bases.
Require Import defs.
Require Import semantics.
Require Import signature.

(* reconnaissance des listes de termes par chemins dans les prec_list *)

Inductive pl_path : Set :=
  | pl_path_nil : pl_path
  | pl_path_cons : ad -> pl_path -> pl_path.

Inductive pl_path_incl : pl_path -> prec_list -> Prop :=
  | pl_path_incl_nil : pl_path_incl pl_path_nil prec_empty
  | pl_path_incl_cons :
      forall (plp : pl_path) (a : ad) (la ls : prec_list),
      pl_path_incl plp la ->
      pl_path_incl (pl_path_cons a plp) (prec_cons a la ls)
  | pl_path_incl_next :
      forall (plp : pl_path) (a : ad) (la ls : prec_list),
      pl_path_incl plp ls ->
      plp <> pl_path_nil -> pl_path_incl plp (prec_cons a la ls).

Inductive pl_path_recon : preDTA -> term_list -> pl_path -> Prop :=
  | pl_path_rec_nil : forall d : preDTA, pl_path_recon d tnil pl_path_nil
  | pl_path_rec_cons :
      forall (d : preDTA) (a : ad) (t : term) (plp : pl_path)
        (tl : term_list),
      reconnaissance d a t ->
      pl_path_recon d tl plp ->
      pl_path_recon d (tcons t tl) (pl_path_cons a plp).

Definition pl_path_rec_equiv_0_def (d : preDTA) (pl : prec_list)
  (tl : term_list) :=
  liste_reconnait d pl tl ->
  exists plp : pl_path, pl_path_incl plp pl /\ pl_path_recon d tl plp.

Fixpoint pl_path_length (plp : pl_path) : nat :=
  match plp with
  | pl_path_nil => 0
  | pl_path_cons _ p => S (pl_path_length p)
  end.

(* existence de chemins dans les prec_list *)

Lemma pl_path_exists :
 forall pl : prec_list, exists p : pl_path, pl_path_incl p pl.
Proof.
	simple induction pl. intros. elim H. intros. split with (pl_path_cons a x).
	exact (pl_path_incl_cons x a p p0 H1). split with pl_path_nil.
	exact pl_path_incl_nil.
Qed.

Lemma non_empty_pl_path_exists :
 forall pl : prec_list,
 pl <> prec_empty ->
 exists p : pl_path, pl_path_incl p pl /\ 1 <= pl_path_length p.
Proof.
	simple induction pl. intros. elim (pl_path_exists p). intros. split with (pl_path_cons a x).
	split. exact (pl_path_incl_cons x a p p0 H2). simpl in |- *. exact (le_n_S _ _ (le_O_n (pl_path_length x))). intros. elim (H (refl_equal _)).
Qed.

(* CNS de reconnaissance d'une liste de terme par une prec_list *)

Lemma pl_path_rec_equiv_0_0 :
 forall d : preDTA, pl_path_rec_equiv_0_def d prec_empty tnil.
Proof.
	unfold pl_path_rec_equiv_0_def in |- *. intros. inversion H. split with pl_path_nil.
	split. exact pl_path_incl_nil. exact (pl_path_rec_nil d).
Qed.

Lemma pl_path_rec_equiv_0_1 :
 forall (d : preDTA) (a : ad) (la ls : prec_list) (hd : term)
   (tl : term_list),
 reconnaissance d a hd ->
 liste_reconnait d la tl ->
 pl_path_rec_equiv_0_def d la tl ->
 pl_path_rec_equiv_0_def d (prec_cons a la ls) (tcons hd tl).
Proof.
	unfold pl_path_rec_equiv_0_def in |- *. intros. elim (H1 H0). intros. elim H3. intros.
	split with (pl_path_cons a x). split. exact (pl_path_incl_cons x a la ls H4).
	exact (pl_path_rec_cons d a hd x tl H H5).
Qed.

Lemma pl_path_rec_equiv_0_2 :
 forall (d : preDTA) (a : ad) (la ls : prec_list) (hd : term)
   (tl : term_list),
 liste_reconnait d ls (tcons hd tl) ->
 pl_path_rec_equiv_0_def d ls (tcons hd tl) ->
 pl_path_rec_equiv_0_def d (prec_cons a la ls) (tcons hd tl).
Proof.
	unfold pl_path_rec_equiv_0_def in |- *. intros. elim (H0 H). intros. split with x.
	elim H2. intros. split. apply (pl_path_incl_next x a la ls). exact H3.
	intro. rewrite H5 in H4. inversion H4. exact H4.
Qed.

Lemma pl_path_rec_equiv_0_3 :
 forall (p : preDTA) (p0 : prec_list) (t : term_list),
 liste_reconnait p p0 t -> pl_path_rec_equiv_0_def p p0 t.
Proof.
	exact
  (liste_reconnait_ind pl_path_rec_equiv_0_def pl_path_rec_equiv_0_0
     pl_path_rec_equiv_0_1 pl_path_rec_equiv_0_2).
Qed.

Lemma pl_path_rec_equiv_0 :
 forall (d : preDTA) (pl : prec_list) (tl : term_list),
 liste_reconnait d pl tl ->
 exists plp : pl_path, pl_path_incl plp pl /\ pl_path_recon d tl plp.
Proof.
	intros. elim (pl_path_rec_equiv_0_3 d pl tl H H). intros. split with x. exact H0.
Qed.

Definition pl_path_rec_equiv_1_def (plp : pl_path)
  (pl : prec_list) :=
  pl_path_incl plp pl ->
  forall (d : preDTA) (tl : term_list) (n : nat),
  pl_path_recon d tl plp -> pl_tl_length pl n -> liste_reconnait d pl tl.

Lemma pl_path_rec_equiv_1_0 : pl_path_rec_equiv_1_def pl_path_nil prec_empty.
Proof.
	unfold pl_path_rec_equiv_1_def in |- *. intros. inversion H0.
	exact (rec_empty d).
Qed.

Lemma pl_path_rec_equiv_1_1 :
 forall (plp : pl_path) (a : ad) (la ls : prec_list),
 pl_path_incl plp la ->
 pl_path_rec_equiv_1_def plp la ->
 pl_path_rec_equiv_1_def (pl_path_cons a plp) (prec_cons a la ls).
Proof.
	unfold pl_path_rec_equiv_1_def in |- *. intros. inversion H2. apply (rec_consi d a la ls t tl0). exact H8. induction  n as [| n Hrecn]. inversion H3. apply (H0 H d tl0 n H9). inversion H3. exact H11. exact H12.
Qed.

Lemma pl_path_rec_equiv_1_2 :
 forall (plp : pl_path) (a : ad) (la ls : prec_list),
 pl_path_incl plp ls ->
 pl_path_rec_equiv_1_def plp ls ->
 plp <> pl_path_nil -> pl_path_rec_equiv_1_def plp (prec_cons a la ls).
Proof.
	unfold pl_path_rec_equiv_1_def in |- *. intros. induction  n as [| n Hrecn].
        inversion_clear H4.
	induction  tl as [| t tl Hrectl]. inversion H3. rewrite <- H7 in H2. inversion_clear H2.
	elim H8; trivial.
        apply (rec_consn d a la ls t tl).
	apply (H0 H d (tcons t tl) (S n) H3). inversion H4. rewrite <- H8 in H.
	inversion H. elim H1; auto.
        exact H10.
Qed.

Lemma pl_path_rec_equiv_1_3 :
 forall (p : pl_path) (p0 : prec_list),
 pl_path_incl p p0 -> pl_path_rec_equiv_1_def p p0.
Proof.
	exact
  (pl_path_incl_ind pl_path_rec_equiv_1_def pl_path_rec_equiv_1_0
     pl_path_rec_equiv_1_1 pl_path_rec_equiv_1_2).
Qed.

Lemma pl_path_rec_equiv_1 :
 forall (plp : pl_path) (pl : prec_list),
 pl_path_incl plp pl ->
 forall (d : preDTA) (tl : term_list) (n : nat),
 pl_path_recon d tl plp -> pl_tl_length pl n -> liste_reconnait d pl tl.
Proof.
	intros. exact (pl_path_rec_equiv_1_3 plp pl H H d tl n H0 H1).
Qed.

Lemma pl_path_rec_length :
 forall (plp : pl_path) (tl : term_list) (d : preDTA),
 pl_path_recon d tl plp -> pl_path_length plp = lst_length tl.
Proof.
	simple induction plp. intros. inversion H. simpl in |- *. reflexivity. intros. inversion H0.
	simpl in |- *. rewrite (H tl0 d). reflexivity. exact H6.
Qed.

Definition liste_rec_length_def (d : preDTA) (pl : prec_list)
  (tl : term_list) : Prop :=
  forall n : nat,
  liste_reconnait d pl tl -> pl_tl_length pl n -> n = lst_length tl.

Lemma liste_rec_length_0 :
 forall d : preDTA, liste_rec_length_def d prec_empty tnil.
Proof.
	unfold liste_rec_length_def in |- *. intros. inversion H0. reflexivity.
Qed.

Lemma liste_rec_length_1 :
 forall (d : preDTA) (a : ad) (la ls : prec_list) (hd : term)
   (tl : term_list),
 reconnaissance d a hd ->
 liste_reconnait d la tl ->
 liste_rec_length_def d la tl ->
 liste_rec_length_def d (prec_cons a la ls) (tcons hd tl).
Proof.
	unfold liste_rec_length_def in |- *. intros. induction  n as [| n Hrecn]. inversion H3. inversion H3.
	simpl in |- *. rewrite <- (H1 n H0 H5). reflexivity. simpl in |- *. rewrite <- (H1 n H0 H6).
	reflexivity.
Qed.

Lemma liste_rec_length_2 :
 forall (d : preDTA) (a : ad) (la ls : prec_list) (hd : term)
   (tl : term_list),
 liste_reconnait d ls (tcons hd tl) ->
 liste_rec_length_def d ls (tcons hd tl) ->
 liste_rec_length_def d (prec_cons a la ls) (tcons hd tl).
Proof.
	unfold liste_rec_length_def in |- *. intros. simpl in |- *. induction  n as [| n Hrecn]. inversion H2.
	simpl in H0. inversion H2. rewrite <- H6 in H. inversion H.
	rewrite <- (H0 (S n) H H8). reflexivity.
Qed.

Lemma liste_rec_length_3 :
 forall (p : preDTA) (p0 : prec_list) (t : term_list),
 liste_reconnait p p0 t -> liste_rec_length_def p p0 t.
Proof.
	exact
  (liste_reconnait_ind liste_rec_length_def liste_rec_length_0
     liste_rec_length_1 liste_rec_length_2).
Qed.

Lemma liste_rec_length :
 forall (pl : prec_list) (tl : term_list) (d : preDTA) (n : nat),
 liste_reconnait d pl tl -> pl_tl_length pl n -> n = lst_length tl.
Proof.
	intros. exact (liste_rec_length_3 d pl tl H n H H0).
Qed.

Definition pl_path_incl_length_def (plp : pl_path)
  (pl : prec_list) : Prop :=
  forall n : nat,
  pl_path_incl plp pl -> pl_tl_length pl n -> pl_path_length plp = n.

Lemma pl_path_incl_length_0 : pl_path_incl_length_def pl_path_nil prec_empty.
Proof.
	unfold pl_path_incl_length_def in |- *. intros. inversion H0. reflexivity.
Qed.

Lemma pl_path_incl_length_1 :
 forall (plp : pl_path) (a : ad) (la ls : prec_list),
 pl_path_incl plp la ->
 pl_path_incl_length_def plp la ->
 pl_path_incl_length_def (pl_path_cons a plp) (prec_cons a la ls).
Proof.
	unfold pl_path_incl_length_def in |- *. intros. inversion H2. simpl in |- *.
	rewrite (H0 n0 H H7). reflexivity. simpl in |- *. rewrite (H0 n0 H H7).
	reflexivity.
Qed.

Lemma pl_path_incl_length_2 :
 forall (plp : pl_path) (a : ad) (la ls : prec_list),
 pl_path_incl plp ls ->
 pl_path_incl_length_def plp ls ->
 plp <> pl_path_nil -> pl_path_incl_length_def plp (prec_cons a la ls).
Proof.
	unfold pl_path_incl_length_def in |- *. intros. inversion H3. rewrite <- H7 in H.
	inversion H. elim (H1 (sym_eq H9)). exact (H0 (S n0) H H9).
Qed.

Lemma pl_path_incl_length_3 :
 forall (p : pl_path) (p0 : prec_list),
 pl_path_incl p p0 -> pl_path_incl_length_def p p0.
Proof.
	exact
  (pl_path_incl_ind pl_path_incl_length_def pl_path_incl_length_0
     pl_path_incl_length_1 pl_path_incl_length_2).
Qed.

Lemma pl_path_incl_length :
 forall (plp : pl_path) (pl : prec_list) (n : nat),
 pl_path_incl plp pl -> pl_tl_length pl n -> pl_path_length plp = n.
Proof.
	intros. exact
  (pl_path_incl_ind pl_path_incl_length_def pl_path_incl_length_0
     pl_path_incl_length_1 pl_path_incl_length_2 plp pl H n H H0).
Qed.

(* CNS pour la propriété pl_tl_length, partie suffisante *)

Lemma forall_incl_length :
 forall (pl : prec_list) (n : nat),
 (forall p : pl_path, pl_path_incl p pl -> pl_path_length p = n) ->
 pl_tl_length pl n.
Proof.
	simple induction pl. intros. elim (nat_sum n); intros. rewrite H2 in H1.
	elim (non_empty_pl_path_exists (prec_cons a p p0)). intros.
	elim (le_Sn_O 0). elim H3. intros. rewrite (H1 x H4) in H5. exact H5.
	intro. inversion H3. elim H2. intros. rewrite H3. rewrite H3 in H1.
	elim (pl_sum p0); intros. rewrite H4. apply (pl_tl_S a p x). apply (H x). intros. apply (Sn_eq_Sm_n_eq_m (pl_path_length p1) x). replace (S (pl_path_length p1)) with (pl_path_length (pl_path_cons a p1)).
	apply (H1 (pl_path_cons a p1)). exact (pl_path_incl_cons p1 a p p0 H5).
	reflexivity. apply (pl_tl_propag a p p0 x). apply (H x). intros.
	cut (pl_path_length (pl_path_cons a p1) = S x). intros. simpl in H6.
	inversion H6. reflexivity. exact (H1 (pl_path_cons a p1) (pl_path_incl_cons p1 a p p0 H5)). apply (H0 (S x)). intros. apply (H1 p1). apply (pl_path_incl_next p1 a p p0 H5). intro. rewrite H6 in H5. elim H4. intros. elim H7. intros. elim H8. intros.
	rewrite H9 in H5. inversion H5. exact (H15 (refl_equal _)).
	intros. induction  n as [| n Hrecn]. exact pl_tl_O. elim (pl_path_exists prec_empty).
	intros. cut (S n = 0). intros. inversion H1. transitivity (pl_path_length x). symmetry  in |- *. exact (H x H0). inversion H0.
	reflexivity.
Qed.


From iris.program_logic Require Export weakestpre.
From iris.proofmode Require Import tactics.
Set Default Proof Using "Type".

Section lifting.
Context `{irisG Λ Σ}.
Implicit Types s : stuckness.
Implicit Types v : val Λ.
Implicit Types e : expr Λ.
Implicit Types σ : state Λ.
Implicit Types P Q : iProp Σ.
Implicit Types Φ : val Λ → iProp Σ.

Lemma wp_lift_step_fupd s E Φ e1 :
  to_val e1 = None →
  (∀ σ1, state_interp σ1 ={E,∅}=∗
    ⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗
    ∀ e2 σ2 efs, ⌜prim_step e1 σ1 e2 σ2 efs⌝ ={∅,∅,E}▷=∗
      state_interp σ2 ∗ WP e2 @ s; E {{ Φ }} ∗ [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ _, True }})
  ⊢ WP e1 @ s; E {{ Φ }}.
Proof.
  rewrite wp_unfold /wp_pre=>->. iIntros "H" (σ1) "Hσ".
  iMod ("H" with "Hσ") as "(%&H)". iModIntro. iSplit. by destruct s. done.
Qed.

Lemma wp_lift_stuck E Φ e :
  to_val e = None →
  (∀ σ, state_interp σ ={E,∅}=∗ ⌜stuck e σ⌝)
  ⊢ WP e @ E ?{{ Φ }}.
Proof.
  rewrite wp_unfold /wp_pre=>->. iIntros "H" (σ1) "Hσ".
  iMod ("H" with "Hσ") as %[? Hirr]. iModIntro. iSplit; first done.
  iIntros (e2 σ2 efs) "% !> !>". by case: (Hirr e2 σ2 efs).
Qed.

(** Derived lifting lemmas. *)
Lemma wp_lift_step s E Φ e1 :
  to_val e1 = None →
  (∀ σ1, state_interp σ1 ={E,∅}=∗
    ⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗
    ▷ ∀ e2 σ2 efs, ⌜prim_step e1 σ1 e2 σ2 efs⌝ ={∅,E}=∗
      state_interp σ2 ∗ WP e2 @ s; E {{ Φ }} ∗ [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ _, True }})
  ⊢ WP e1 @ s; E {{ Φ }}.
Proof.
  iIntros (?) "H". iApply wp_lift_step_fupd; [done|]. iIntros (?) "Hσ".
  iMod ("H" with "Hσ") as "[$ H]". iIntros "!> * % !>". by iApply "H".
Qed.

Lemma wp_lift_pure_step `{Inhabited (state Λ)} s E E' Φ e1 :
  (∀ σ1, if s is NotStuck then reducible e1 σ1 else to_val e1 = None) →
  (∀ σ1 e2 σ2 efs, prim_step e1 σ1 e2 σ2 efs → σ1 = σ2) →
  (|={E,E'}▷=> ∀ e2 efs σ, ⌜prim_step e1 σ e2 σ efs⌝ →
    WP e2 @ s; E {{ Φ }} ∗ [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ _, True }})
  ⊢ WP e1 @ s; E {{ Φ }}.
Proof.
  iIntros (Hsafe Hstep) "H". iApply wp_lift_step.
  { specialize (Hsafe inhabitant). destruct s; last done.
      by eapply reducible_not_val. }
  iIntros (σ1) "Hσ". iMod "H".
  iMod fupd_intro_mask' as "Hclose"; last iModIntro; first by set_solver. iSplit.
  { iPureIntro. destruct s; done. }
  iNext. iIntros (e2 σ2 efs ?).
  destruct (Hstep σ1 e2 σ2 efs); auto; subst.
  iMod "Hclose" as "_". iFrame "Hσ". iMod "H". iApply "H"; auto.
Qed.

Lemma wp_lift_pure_stuck `{Inhabited (state Λ)} E Φ e :
  (∀ σ, stuck e σ) →
  True ⊢ WP e @ E ?{{ Φ }}.
Proof.
  iIntros (Hstuck) "_". iApply wp_lift_stuck.
  - destruct(to_val e) as [v|] eqn:He; last done.
    rewrite -He. by case: (Hstuck inhabitant).
  - iIntros (σ) "_". iMod (fupd_intro_mask' E ∅) as "_".
    by set_solver. by auto.
Qed.

(* Atomic steps don't need any mask-changing business here, one can
   use the generic lemmas here. *)
Lemma wp_lift_atomic_step_fupd {s E1 E2 Φ} e1 :
  to_val e1 = None →
  (∀ σ1, state_interp σ1 ={E1}=∗
    ⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗
    ∀ e2 σ2 efs, ⌜prim_step e1 σ1 e2 σ2 efs⌝ ={E1,E2}▷=∗
      state_interp σ2 ∗
      from_option Φ False (to_val e2) ∗ [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ _, True }})
  ⊢ WP e1 @ s; E1 {{ Φ }}.
Proof.
  iIntros (?) "H". iApply (wp_lift_step_fupd s E1 _ e1)=>//; iIntros (σ1) "Hσ1".
  iMod ("H" $! σ1 with "Hσ1") as "[$ H]".
  iMod (fupd_intro_mask' E1 ∅) as "Hclose"; first set_solver.
  iIntros "!>" (e2 σ2 efs ?). iMod "Hclose" as "_".
  iMod ("H" $! e2 σ2 efs with "[#]") as "H"; [done|].
  iMod (fupd_intro_mask' E2 ∅) as "Hclose"; [set_solver|]. iIntros "!> !>".
  iMod "Hclose" as "_". iMod "H" as "($ & HΦ & $)".
  destruct (to_val e2) eqn:?; last by iExFalso.
  iApply wp_value; last done. by apply of_to_val.
Qed.

Lemma wp_lift_atomic_step {s E Φ} e1 :
  to_val e1 = None →
  (∀ σ1, state_interp σ1 ={E}=∗
    ⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗
    ▷ ∀ e2 σ2 efs, ⌜prim_step e1 σ1 e2 σ2 efs⌝ ={E}=∗
      state_interp σ2 ∗
      from_option Φ False (to_val e2) ∗ [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ _, True }})
  ⊢ WP e1 @ s; E {{ Φ }}.
Proof.
  iIntros (?) "H". iApply wp_lift_atomic_step_fupd; [done|].
  iIntros (?) "?". iMod ("H" with "[$]") as "[$ H]". iIntros "!> * % !> !>".
  by iApply "H".
Qed.

Lemma wp_lift_pure_det_step `{Inhabited (state Λ)} {s E E' Φ} e1 e2 efs :
  (∀ σ1, if s is NotStuck then reducible e1 σ1 else to_val e1 = None) →
  (∀ σ1 e2' σ2 efs', prim_step e1 σ1 e2' σ2 efs' → σ1 = σ2 ∧ e2 = e2' ∧ efs = efs')→
  (|={E,E'}▷=> WP e2 @ s; E {{ Φ }} ∗ [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ _, True }})
  ⊢ WP e1 @ s; E {{ Φ }}.
Proof.
  iIntros (? Hpuredet) "H". iApply (wp_lift_pure_step s E E'); try done.
  { by intros; eapply Hpuredet. }
  iApply (step_fupd_wand with "H"); iIntros "H".
  by iIntros (e' efs' σ (_&->&->)%Hpuredet).
Qed.

Lemma wp_pure_step_fupd `{Inhabited (state Λ)} s E E' e1 e2 φ Φ :
  PureExec φ e1 e2 →
  φ →
  (|={E,E'}▷=> WP e2 @ s; E {{ Φ }}) ⊢ WP e1 @ s; E {{ Φ }}.
Proof.
  iIntros ([??] Hφ) "HWP".
  iApply (wp_lift_pure_det_step with "[HWP]").
  - intros σ. specialize (pure_exec_safe σ). destruct s; eauto using reducible_not_val.
  - destruct s; naive_solver.
  - by rewrite big_sepL_nil right_id.
Qed.

Lemma wp_pure_step_later `{Inhabited (state Λ)} s E e1 e2 φ Φ :
  PureExec φ e1 e2 →
  φ →
  ▷ WP e2 @ s; E {{ Φ }} ⊢ WP e1 @ s; E {{ Φ }}.
Proof.
  intros ??. rewrite -wp_pure_step_fupd //. rewrite -step_fupd_intro //.
Qed.
End lifting.


(* Distributed under the terms of the MIT license. *)
From MetaCoq.Template Require Import utils Ast AstUtils Environment Induction WfAst.
From Coq Require Import ssreflect.
From Equations Require Import Equations.

(** * Lifting and substitution for the AST

  Along with standard commutation lemmas.
  Definition of [closedn] (boolean) predicate for checking if
  a term is closed. *)

Definition up := lift 1 0.

Create HintDb terms.

Ltac arith_congr := repeat (try lia; progress f_equal).

Ltac easy0 :=
  let rec use_hyp H :=
   (match type of H with
    | _ /\ _ => exact H || destruct_hyp H
    | _ * _ => exact H || destruct_hyp H
    | _ => try (solve [ inversion H ])
    end)
  with do_intro := (let H := fresh in
                    intro H; use_hyp H)
  with destruct_hyp H := (case H; clear H; do_intro; do_intro)
  in
  let rec use_hyps :=
   (match goal with
    | H:_ /\ _ |- _ => exact H || (destruct_hyp H; use_hyps)
    | H:_ * _ |- _ => exact H || (destruct_hyp H; use_hyps)
    | H:_ |- _ => solve [ inversion H ]
    | _ => idtac
    end)
  in
  let do_atom := (solve [ trivial with eq_true | reflexivity | symmetry; trivial | contradiction | congruence]) in
  let rec do_ccl := (try do_atom; repeat (do_intro; try do_atom); try arith_congr; (solve [ split; do_ccl ])) in
  (solve [ do_atom | use_hyps; do_ccl ]) || fail "Cannot solve this goal".

#[global]
Hint Extern 10 (_ < _)%nat => lia : terms.
#[global]
Hint Extern 10 (_ <= _)%nat => lia : terms.
#[global]
Hint Extern 10 (@eq nat _ _) => lia : terms.

Ltac easy ::= easy0 || solve [intuition eauto 3 with core terms].

Notation subst_rec N M k := (subst N k M) (only parsing).

Require Import PeanoNat.
Import Nat.

Lemma lift_rel_ge :
  forall k n p, p <= n -> lift k p (tRel n) = tRel (k + n).
Proof.
  intros; simpl in |- *.
  now elim (leb_spec p n).
Qed.

Lemma lift_rel_lt : forall k n p, p > n -> lift k p (tRel n) = tRel n.
Proof.
  intros; simpl in |- *.
  now elim (leb_spec p n).
Qed.

Lemma subst_rel_lt : forall u n k, k > n -> subst u k (tRel n) = tRel n.
Proof.
  simpl in |- *; intros.
  elim (leb_spec k n); intro Hcomp; easy.
Qed.

Lemma subst_rel_gt :
  forall u n k, n >= k + length u -> subst u k (tRel n) = tRel (n - length u).
Proof.
  simpl in |- *; intros.
  elim (leb_spec k n). intros. destruct nth_error eqn:Heq.
  assert (n - k < length u) by (apply nth_error_Some; congruence). lia. reflexivity.
  lia.
Qed.

Lemma subst_rel_eq :
  forall (u : list term) n i t p,
    List.nth_error u i = Some t -> p = n + i ->
    subst u n (tRel p) = lift0 n t.
Proof.
  intros; simpl in |- *. subst p.
  elim (leb_spec n (n + i)). intros. assert (n + i - n = i) by lia. rewrite H1 H.
  reflexivity. intros. lia.
Qed.

Lemma lift0_id : forall M k, lift 0 k M = M.
Proof.
  intros M.
  elim M using term_forall_list_ind; simpl in |- *; intros; try easy ;
    try (try rewrite H; try rewrite H0 ; try rewrite H1 ; easy);
    try (f_equal; auto; solve_all).
  now elim (leb k n).
Qed.

Lemma lift0_p : forall M, lift0 0 M = M.
Proof.
  intros; unfold lift in |- *.
  apply lift0_id; easy.
Qed.

Lemma simpl_lift :
  forall M n k p i,
    i <= k + n ->
    k <= i -> lift p i (lift n k M) = lift (p + n) k M.
Proof.
  intros M.
  elim M using term_forall_list_ind;
    intros; simpl;
      rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length;
      rewrite -> ?map_predicate_map_predicate;
      try (rewrite -> H, ?H0, ?H1; auto); try (f_equal; auto; solve_all).

  - elim (leb_spec k n); intros.
    + elim (leb_spec i (n0 + n)); intros; lia.
    + elim (leb_spec i n); intros; lia.
Qed.

Lemma simpl_lift0 : forall M n, lift0 (S n) M = lift0 1 (lift0 n M).
  now intros; rewrite simpl_lift.
Qed.

Lemma map_branches_k_map_branches_k
      {term term' term''}
      (f : nat -> term' -> term'')
      (g : branch term -> term -> term')
      (f' : term -> term')
      (l : list (branch term)) k :
  map (fun b => map_branch (f (#|bcontext (map_branch (g b) b)| + k)) (map_branch f' b)) l =
  map (fun b => map_branch (f (#|bcontext b| + k)) (map_branch f' b)) l.
Proof.
  eapply map_ext => b. rewrite map_branch_map_branch.
  now apply map_branch_eq_spec.
Qed.

Lemma permute_lift :
  forall M n k p i,
    i <= k ->
    lift p i (lift n k M) = lift n (k + p) (lift p i M).
Proof.
  intros M.
  elim M using term_forall_list_ind;
    intros; simpl;
      rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length,
      ?Nat.add_assoc, ?map_predicate_map_predicate, ?map_branches_map_branches; f_equal;
      try solve [auto; solve_all]; repeat nth_leb_simpl.
Qed.

Lemma permute_lift0 :
  forall M k, lift0 1 (lift 1 k M) = lift 1 (S k) (lift0 1 M).
  intros.
  change (lift 1 0 (lift 1 k M) = lift 1 (1 + k) (lift 1 0 M))
    in |- *.
  rewrite permute_lift; easy.
Qed.

Lemma map_non_nil {A B} (f : A -> B) l : l <> nil -> map f l <> nil.
Proof.
  intros. intro.
  destruct l; try discriminate.
  contradiction.
Qed.

Lemma isLambda_lift n k (bod : term) :
  isLambda bod = true -> isLambda (lift n k bod) = true.
Proof. destruct bod; simpl; try congruence. Qed.

#[global]
Hint Resolve lift_isApp map_non_nil isLambda_lift : all.

Lemma mkApps_tApp t l :
  isApp t = false -> l <> nil -> mkApps t l = tApp t l.
Proof.
  intros.
  destruct l. simpl. contradiction.
  destruct t; simpl; try reflexivity.
  simpl in H. discriminate.
Qed.

Lemma simpl_subst_rec :
  forall Σ M (H : wf Σ M) N n p k,
    p <= n + k ->
    k <= p -> subst N p (lift (List.length N + n) k M) = lift n k M.
Proof.
  intros Σ M wfM. induction wfM using term_wf_forall_list_ind;
    intros; simpl;
      rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length,
                 ?map_predicate_map_predicate;
      try solve [f_equal; auto; solve_all]; repeat nth_leb_simpl.

  - rewrite IHwfM; auto.
    apply (lift_isApp n k) in H.
    rewrite mkApps_tApp; auto using map_non_nil.
    f_equal; solve_all.
Qed.

Lemma simpl_subst Σ :
  forall N M (H : wf Σ M) n p, p <= n -> subst N p (lift0 (length N + n) M) = lift0 n M.
Proof.  intros. erewrite simpl_subst_rec; eauto. now rewrite Nat.add_0_r. lia. Qed.

Lemma mkApps_tRel n a l : mkApps (tRel n) (a :: l) = tApp (tRel n) (a :: l).
Proof.
  simpl. reflexivity.
Qed.

Lemma lift_mkApps n k t l : lift n k (mkApps t l) = mkApps (lift n k t) (map (lift n k) l).
Proof.
  revert n k t; induction l; intros n k t; destruct t; try reflexivity.
  simpl. f_equal.
  now rewrite map_app.
Qed.

Lemma commut_lift_subst_rec :
  forall M N n p k,
    k <= p ->
    lift n k (subst N p M) = subst N (p + n) (lift n k M).
Proof.
  intros M.
  elim M using term_forall_list_ind;
    intros; simpl; try easy;
      rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length, ?Nat.add_assoc,
                 ?map_predicate_map_predicate;
      try solve [f_equal; auto; solve_all].

  - repeat nth_leb_simpl.
    rewrite -> simpl_lift by easy. f_equal; lia.
  - rewrite lift_mkApps. f_equal. auto.
    rewrite map_map_compose. solve_all.
Qed.

Lemma commut_lift_subst :
  forall M N k, subst N (S k) (lift0 1 M) = lift0 1 (subst N k M).
  now intros; rewrite commut_lift_subst_rec.
Qed.

Lemma distr_lift_subst_rec :
  forall M N n p k,
    lift n (p + k) (subst N p M) =
    subst (List.map (lift n k) N) p (lift n (p + length N + k) M).
Proof.
  intros M.
  elim M using term_forall_list_ind;
    intros; match goal with
              |- context [tRel _] => idtac
            | |- _ => cbn -[plus]
            end; try easy;
      rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length, ?Nat.add_assoc,
                 ?map_predicate_map_predicate;
      try solve [f_equal; auto; solve_all].

  - unfold subst at 1. unfold lift at 4.
    repeat nth_leb_simpl.
    rewrite nth_error_map in e0. rewrite e in e0.
    revert e0. intros [= <-].
    now rewrite (permute_lift x n0 k p 0).
  - rewrite lift_mkApps. f_equal; auto.
    rewrite map_map_compose; solve_all.
Qed.

Lemma distr_lift_subst :
  forall M N n k,
    lift n k (subst0 N M) = subst0 (map (lift n k) N) (lift n (length N + k) M).
Proof.
  intros. pattern k at 1 3 in |- *.
  replace k with (0 + k); try easy.
  apply distr_lift_subst_rec.
Qed.

Lemma distr_lift_subst10 :
  forall M N n k,
    lift n k (subst10 N M) = subst10 (lift n k N) (lift n (S k) M).
Proof.
  intros; unfold subst in |- *.
  pattern k at 1 3 in |- *.
  replace k with (0 + k); try easy.
  apply distr_lift_subst_rec.
Qed.

Lemma subst_mkApps u k t l :
  subst u k (mkApps t l) = mkApps (subst u k t) (map (subst u k) l).
Proof.
  revert u k t; induction l; intros u k t; destruct t; try reflexivity.
  intros. simpl mkApps at 1. simpl subst at 1 2. rewrite map_app. now rewrite -mkApps_app.
Qed.

Lemma subst1_mkApps u k t l : subst1 u k (mkApps t l) = mkApps (subst1 u k t) (map (subst1 u k) l).
Proof.
  apply subst_mkApps.
Qed.

Lemma distr_subst_rec Σ :
  forall M N (P : list term) (wfP : All (wf Σ) P) n p,
    subst P (p + n) (subst N p M) =
    subst (map (subst P n) N) p (subst P (p + length N + n) M).
Proof.
  intros M.
  elim M using term_forall_list_ind;
    intros; match goal with
              |- context [tRel _] => idtac
            | |- _ => simpl
            end; try easy;
      rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length, ?Nat.add_assoc,
                 ?map_predicate_map_predicate;
      try solve [f_equal; auto; solve_all].

  - unfold subst at 2.
    elim (leb_spec p n); intros; try easy.

    + destruct (nth_error_spec N (n - p)).
      ++ rewrite -> subst_rel_lt by lia.
         erewrite subst_rel_eq; try easy.
         2:rewrite -> nth_error_map, e; reflexivity.
         now rewrite commut_lift_subst_rec. lia.
      ++ unfold subst at 4.
         elim (leb_spec (p + length N + n0) n); intros; subst; try easy.
         destruct (nth_error_spec P (n - (p + length N + n0))).
         +++ erewrite subst_rel_eq. 2:eauto. 2:lia.
             assert (p + length N + n0 = length (map (subst P n0) N) + (p + n0))
               by (rewrite map_length; lia).
             rewrite H1. erewrite simpl_subst_rec; eauto; try lia.
             eapply nth_error_all in e; eauto.
         +++ rewrite !subst_rel_gt; rewrite ?map_length; try lia. f_equal; lia.
         +++ rewrite subst_rel_lt; try easy.
             rewrite -> subst_rel_gt; rewrite map_length. trivial. lia.
    + rewrite !subst_rel_lt; try easy.

  - rewrite !subst_mkApps. rewrite H; auto. f_equal.
    rewrite !map_map_compose. solve_all.
Qed.

Lemma distr_subst Σ :
  forall P (wfP : All (wf Σ) P) N M k,
    subst P k (subst0 N M) = subst0 (map (subst P k) N) (subst P (length N + k) M).
Proof.
  intros.
  pattern k at 1 3 in |- *.
  change k with (0 + k). hnf.
  eapply distr_subst_rec; eauto.
Qed.

Lemma lift_closed n k t : closedn k t -> lift n k t = t.
Proof.
  revert k.
  elim t using term_forall_list_ind; intros; try easy;
    rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length,
               ?map_predicate_map_predicate;
    simpl closed in *;
    unfold test_def, test_predicate in *;
    try solve [simpl lift; simpl closed; f_equal; auto; rtoProp; solve_all]; try easy.
  - rewrite lift_rel_lt; auto.
    revert H. elim (Nat.ltb_spec n0 k); intros; try easy.
  - simpl lift. f_equal. solve_all. unfold test_def in b. toProp. solve_all.
  - simpl lift. f_equal. solve_all. unfold test_def in b. toProp. solve_all.
Qed.

Lemma closed_upwards {k t} k' : closedn k t -> k' >= k -> closedn k' t.
Proof.
  revert k k'.
  elim t using term_forall_list_ind; intros; try lia;
    rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length,
               ?map_predicate_map_predicate;
    simpl closed in *; unfold test_snd, test_def, test_predicate, test_branch in *;
      try solve [(try f_equal; simpl; repeat (rtoProp; solve_all); eauto)].

  - elim (ltb_spec n k'); auto. intros.
    apply ltb_lt in H. lia.
Qed.

Lemma subst_empty Σ k a : wf Σ a -> subst [] k a = a.
Proof.
  induction 1 in k |- * using term_wf_forall_list_ind; simpl; try congruence;
    try solve [f_equal; eauto; solve_all].

  - elim (Nat.compare_spec k n); destruct (Nat.leb_spec k n); intros; try easy.
    subst. rewrite Nat.sub_diag. simpl. rewrite Nat.sub_0_r. reflexivity.
    assert (n - k > 0) by lia.
    assert (exists n', n - k = S n'). exists (pred (n - k)). lia.
    destruct H2. rewrite H2. simpl. now rewrite Nat.sub_0_r.
  - rewrite IHX. rewrite mkApps_tApp; eauto with wf.
    f_equal; solve_all.
Qed.

Lemma lift_to_extended_list_k Γ k : forall k',
    to_extended_list_k Γ (k' + k) = map (lift0 k') (to_extended_list_k Γ k).
Proof.
  unfold to_extended_list_k.
  intros k'. rewrite !reln_alt_eq !app_nil_r.
  induction Γ in k, k' |- *; simpl; auto.
  destruct a as [na [body|] ty].
  now rewrite <- Nat.add_assoc, (IHΓ (k + 1) k').
  simpl. now rewrite <- Nat.add_assoc, (IHΓ (k + 1) k'), map_app.
Qed.

Lemma simpl_subst_k Σ (N : list term) (M : term) :
  wf Σ M -> forall k p, p = #|N| -> subst N k (lift p k M) = M.
Proof.
  intros. subst p. rewrite <- (Nat.add_0_r #|N|).
  erewrite simpl_subst_rec, lift0_id; eauto.
Qed.

Lemma subst_app_decomp Σ l l' k t :
  wf Σ t -> All (wf Σ) l ->
  subst (l ++ l') k t = subst l' k (subst (List.map (lift0 (length l')) l) k t).
Proof.
  intros wft wfl.
  induction wft in k |- * using term_wf_forall_list_ind; simpl; auto;
    rewrite ?subst_mkApps; try change_Sk;
    try (f_equal; rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length,
                             ?map_predicate_map_predicate;
         eauto; solve_all).

  - repeat nth_leb_simpl.
    rewrite nth_error_map in e0. rewrite e in e0.
    injection e0; intros <-.
    rewrite -> permute_lift by auto.
    rewrite <- (Nat.add_0_r #|l'|).
    erewrite -> simpl_subst_rec, lift0_id; auto with wf; try lia. apply wf_lift.
    eapply nth_error_all in e; eauto.
Qed.

Lemma subst_app_simpl Σ l l' k t :
  wf Σ t -> All (wf Σ) l -> All (wf Σ) l' ->
  subst (l ++ l') k t = subst l k (subst l' (k + length l) t).
Proof.
  intros wft wfl wfl'.
  induction wft in k |- * using term_wf_forall_list_ind; simpl; eauto;
    rewrite ?subst_mkApps; try change_Sk;
    try (f_equal; rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length,
                             ?Nat.add_assoc, ?map_predicate_map_predicate;
         eauto; solve_all; eauto).

  - repeat nth_leb_simpl.
    erewrite -> Nat.add_comm, simpl_subst; eauto.
    eapply nth_error_all in e; eauto.
Qed.

Lemma isLambda_subst (s : list term) k (bod : term) :
  isLambda bod = true -> isLambda (subst s k bod) = true.
Proof.
  intros. destruct bod; try discriminate. reflexivity.
Qed.

Lemma map_vass_map_def g l n k :
  (mapi (fun i (d : def term) => vass (dname d) (lift0 i (dtype d)))
        (map (map_def (lift n k) g) l)) =
  (mapi (fun i d => map_decl (lift n (i + k)) d) (mapi (fun i (d : def term) => vass (dname d) (lift0 i (dtype d))) l)).
Proof.
  rewrite mapi_mapi mapi_map. apply mapi_ext.
  intros. unfold map_decl, vass; simpl; f_equal.
  rewrite permute_lift. lia. f_equal; lia.
Qed.
(*
Lemma noccur_between_subst k n t : noccur_between k n t ->
  closedn (n + k) t -> closedn k t.
Proof.
Qed.  *)                        (* TODO *)

Lemma strip_casts_lift n k t :
  strip_casts (lift n k t) = lift n k (strip_casts t).
Proof.
  induction t in k |- * using term_forall_list_ind; simpl; auto;
    rewrite ?map_map_compose  ?compose_on_snd ?compose_map_def ?map_length;
   f_equal; solve_all; eauto.

  - rewrite lift_mkApps IHt map_map_compose.
    f_equal; solve_all.
  - rewrite !map_predicate_map_predicate.
    unfold map_predicate. f_equal.
    solve_all. solve_all.
Qed.

Lemma mkApps_ex t u l : ∑ f args, Ast.mkApps t (u :: l) = Ast.tApp f args.
Proof.
  induction t; simpl; eexists _, _; reflexivity.
Qed.
(*
Lemma mkApps_tApp' f l l' : mkApps (tApp f l) l' = mkApps f (l ++ l').
Proof.
  induction l'; simpl. rewrite app_nil_r.  *)

Lemma list_length_ind {A} (P : list A -> Type) (p0 : P [])
  (pS : forall d Γ, (forall Γ', #|Γ'| <= #|Γ|  -> P Γ') -> P (d :: Γ))
  Γ : P Γ.
Proof.
  generalize (le_n #|Γ|).
  generalize #|Γ| at 2.
  induction n in Γ |- *.
  destruct Γ; [|simpl; intros; elimtype False; lia].
  intros. apply p0.
  intros.
  destruct Γ; simpl in *.
  apply p0. apply pS. intros. apply IHn. simpl. lia.
Qed.

Lemma strip_casts_mkApps_tApp f l :
  isApp f = false ->
  strip_casts (mkApps f l) = strip_casts (tApp f l).
Proof.
  induction l. simpl; auto.
  intros.
  rewrite mkApps_tApp //.
Qed.

Lemma strip_casts_mkApps f l :
  isApp f = false ->
  strip_casts (mkApps f l) = mkApps (strip_casts f) (map strip_casts l).
Proof.
  intros Hf. rewrite strip_casts_mkApps_tApp //.
Qed.

Lemma subst_it_mkProd_or_LetIn n k ctx t :
  subst n k (it_mkProd_or_LetIn ctx t) =
  it_mkProd_or_LetIn (subst_context n k ctx) (subst n (length ctx + k) t).
Proof.
  induction ctx in n, k, t |- *; simpl; try congruence.
  pose (subst_context_snoc n k ctx a). unfold snoc in e. rewrite e. clear e.
  simpl. rewrite -> IHctx.
  pose (subst_context_snoc n k ctx a). simpl. now destruct a as [na [b|] ty].
Qed.


From stdpp Require Export strings.
From iris.algebra Require Export base.
From Coq Require Import Ascii.
Set Default Proof Using "Type".

(* Directions of rewrites *)
Inductive direction := Left | Right.

(* Some specific versions of operations on strings for the proof mode. We need
those so that we can make [cbv] unfold just them, but not the actual operations
that may appear in users' proofs. *)
Local Notation "b1 && b2" := (if b1 then b2 else false) : bool_scope.

Lemma lazy_andb_true (b1 b2 : bool) : b1 && b2 = true ↔ b1 = true ∧ b2 = true.
Proof. destruct b1, b2; intuition congruence. Qed.

Definition beq (b1 b2 : bool) : bool :=
  match b1, b2 with
  | false, false | true, true => true
  | _, _ => false
  end.

Definition ascii_beq (x y : ascii) : bool :=
  let 'Ascii x1 x2 x3 x4 x5 x6 x7 x8 := x in
  let 'Ascii y1 y2 y3 y4 y5 y6 y7 y8 := y in
  beq x1 y1 && beq x2 y2 && beq x3 y3 && beq x4 y4 &&
    beq x5 y5 && beq x6 y6 && beq x7 y7 && beq x8 y8.

Fixpoint string_beq (s1 s2 : string) : bool :=
  match s1, s2 with
  | "", "" => true
  | String a1 s1, String a2 s2 => ascii_beq a1 a2 && string_beq s1 s2
  | _, _ => false
  end.

Lemma beq_true b1 b2 : beq b1 b2 = true ↔ b1 = b2.
Proof. destruct b1, b2; simpl; intuition congruence. Qed.

Lemma ascii_beq_true x y : ascii_beq x y = true ↔ x = y.
Proof.
  destruct x, y; rewrite /= !lazy_andb_true !beq_true. intuition congruence.
Qed.

Lemma string_beq_true s1 s2 : string_beq s1 s2 = true ↔ s1 = s2.
Proof.
  revert s2. induction s1 as [|x s1 IH]=> -[|y s2] //=.
  rewrite lazy_andb_true ascii_beq_true IH. intuition congruence.
Qed.

Lemma string_beq_reflect s1 s2 : reflect (s1 = s2) (string_beq s1 s2).
Proof. apply iff_reflect. by rewrite string_beq_true. Qed.

Module Export ident.
Inductive ident :=
  | IAnon : positive → ident
  | INamed :> string → ident.
End ident.

Instance maybe_IAnon : Maybe IAnon := λ i,
  match i with IAnon n => Some n | _ => None end.
Instance maybe_INamed : Maybe INamed := λ i,
  match i with INamed s => Some s | _ => None end.

Instance beq_eq_dec : EqDecision ident.
Proof. solve_decision. Defined.

Definition positive_beq := Eval compute in Pos.eqb.

Lemma positive_beq_true x y : positive_beq x y = true ↔ x = y.
Proof. apply Pos.eqb_eq. Qed.

Definition ident_beq (i1 i2 : ident) : bool :=
  match i1, i2 with
  | IAnon n1, IAnon n2 => positive_beq n1 n2
  | INamed s1, INamed s2 => string_beq s1 s2
  | _, _ => false
  end.

Lemma ident_beq_true i1 i2 : ident_beq i1 i2 = true ↔ i1 = i2.
Proof.
  destruct i1, i2; rewrite /= ?string_beq_true ?positive_beq_true; naive_solver.
Qed.

Lemma ident_beq_reflect i1 i2 : reflect (i1 = i2) (ident_beq i1 i2).
Proof. apply iff_reflect. by rewrite ident_beq_true. Qed.

Definition option_bind {A B} (f : A → option B) (mx : option A) : option B :=
  match mx with Some x => f x | None => None end.
Arguments option_bind _ _ _ !_ /.


(** printing ⊢k #⊢k# *)
(** printing ⊢s #⊢s# *)
(** printing ⊢! #⊢# *)
(** printing k⊣ #⊣# *)
(** printing |- #⊢# *)
(** printing ↗! #↗# *)
(** printing ↘! #↘# *)
(** printing ⦂ #:# *)
(** printing <⦂ #<:# *)
(** printing [<=] #⊆# *)
(** printing `union` #∪# *)
(** printing \u #∪# *)
(** printing `notin` #∉# *)
(** printing `in` #∈# *)
(** printing ⊆<⦂ #⊆<:# *)

Set Implicit Arguments.
Require Import Definitions.
Require Import Step.
Require Import Misc.
Require Import ListRelations.
Require Import StructuralProperties.
Require Import OperationProperties.

(** * Definition and Properties of Kernel D#<:#

    This file defines Kernel D#<:# and examines its properties.
 *)

Reserved Notation "[ L ] G ⊢k S <⦂ U" (at level 70).
Inductive subtykn : vars -> env -> typ -> typ -> Prop :=
(** [―――――――――――――――] K-VRefl #
#
    [G ⊢k x.A <: x.A] *)
| snf_vrefl : forall L G x,
    [ L ] G ⊢k typ_sel x <⦂ typ_sel x
(** [―――――――――――] K-Top #
#
    [G ⊢k T <: ⊤] *)
| snf_top : forall L G T,
    [ L ] G ⊢k T <⦂ typ_top
(** [―――――――――――] K-Bot #
#
    [G ⊢k ⊥ <: T] *)
| snf_bot : forall L G T,
    [ L ] G ⊢k typ_bot <⦂ T
(** [G ⊢k S <: T1] #
#
    [G ⊢k T2 <: U] #
#
    [―――――――――――――――――――――――――――――――――――] K-Bnd #
#
    [G ⊢k {A : T1 .. T2} <: {A : S .. U}] *)
| snf_bnd : forall L G S T1 T2 U,
    [ L ] G ⊢k S <⦂ T1 ->
    [ L ] G ⊢k T2 <⦂ U ->
    [ L ] G ⊢k typ_bnd T1 T2 <⦂ typ_bnd S U
(** [G ; x : T ⊢k U1 <: U2] #
#
    [―――――――――――――――――――――――――――――] K-All #
#
    [G ⊢k ∀(x : T)U1 <: ∀(x : T)U2] *)
| snf_all : forall L G T U1 U2 x,
    x `notin` union (fv G)
      (union (fv T) (union (fv U1) (union (fv U2) L))) ->
    [ union L (union (singleton x) (fv T)) ]
      x ~ T ++ G ⊢k open x U1 <⦂ open x U2 ->
    [ L ] G ⊢k typ_all T U1 <⦂ typ_all T U2
(** [G ⊢k G(x) <: {A : S .. ⊤}] #
#
    [―――――――――――――――――――――――――] K-Sel1 #
#
    [G ⊢k S <: x.A] *)
| snf_sel1 : forall L G x T S,
    binds x T G ->
    [ L ] G ⊢k T <⦂ typ_bnd S typ_top ->
    [ L ] G ⊢k S <⦂ (typ_sel $ avar_f x)
(** [G ⊢k G(x) <: {A : ⊥ .. U}] #
#
    [―――――――――――――――――――――――――] K-Sel2 #
#
    [G ⊢k x.A <: U] *)
| snf_sel2 : forall L G x T U,
    binds x T G ->
    [ L ] G ⊢k T <⦂ typ_bnd typ_bot U ->
    [ L ] G ⊢k typ_sel $ avar_f x <⦂ U
where "[ L ] G ⊢k S <⦂ U" := (subtykn L G S U).
Hint Constructors subtykn.

Program Fixpoint subtykn_refl T {measure (typ_struct_measure T)} :
  forall L G,
    [ L ] G ⊢k T <⦂ T := _.
Next Obligation.
  destruct T; eauto.
  - pick_fresh x. econstructor; eauto.
    apply subtykn_refl. autorewrite with measures.
    simpl; lia.
  - constructor; apply subtykn_refl; simpl; lia.
Qed.

Lemma subtykn_sound : forall L G S U,
    [ L ] G ⊢k S <⦂ U ->
    uniq G ->
    G ⊢ S <⦂ U.
Proof.
  induction on subtykn; routine.
  - eapply st_all; trivial.
    cofinite.
    apply open_subst_subty with (x := x); auto.
  - eauto using ty_sub.
  - eauto using ty_sub.
Qed.

Lemma weaken_subtykn_gen : forall L' G1 G2 S U,
    [ L' ] G1 ++ G2 ⊢k S <⦂ U ->
    forall L G,
      L' [=] L `union` fv G ->
      [ L ] G1 ++ G ++ G2 ⊢k S <⦂ U.
Proof.
  dep induction on subtykn; eroutine.
  econstructor.
  - instantiate (1 := x). rewrite H2 in *.
    change (union (dom (H0 ++ H1)) (fv_values fv_typ (H0 ++ H1)))
      with (fv (H0 ++ H1)) in H.
    change (union (dom G) (fv_values fv_typ G)) with (fv G) in H.
    repeat rewrite fv_union in *.
    fold_cls. fsetdec.
  - reassoc 4 with 3.
    eapply IHsubtykn; auto.
    rewrite H2.
    change (union (dom G) (fv_values fv_typ G)) with (fv G).
    clear H. fold_cls.
    fsetdec.
Qed.

Lemma weaken_subtykn : forall L G G' S U,
    [ L `union` fv G' ] G ⊢k S <⦂ U -> [ L ] G' ++ G ⊢k S <⦂ U.
Proof.
  intros. reassoc 2 with 0.
  eapply weaken_subtykn_gen; eauto.
  fsetdec.
Qed.
Local Hint Resolve weaken_subtykn.

(** ** Lack of Transitivity

    Despite that Kernel D#<:# has no transitivity, it is still possible to show that
    Kernel D#<:# is transitivity on [⊤] and [⊥].
 *)

Fixpoint bnd_layer (T : typ) (Ts : list typ) : typ :=
  match Ts with
  | nil => T
  | cons T' Ts =>
    typ_bnd T' (bnd_layer T Ts)
  end.

Lemma trans_on_top : forall L G T,
    [ L ] G ⊢k typ_top <⦂ T ->
    forall S,
      [ L ] G ⊢k S <⦂ T
with layered_top_trans : forall L G T l U,
    [ L ] G ⊢k T <⦂ bnd_layer (typ_bnd typ_top U) l ->
    forall S,
      [ L ] G ⊢k T <⦂ bnd_layer (typ_bnd S U) l.
Proof.
  - clear trans_on_top.
    dep induction on subtykn; eroutine.
    econstructor; eauto.
    apply layered_top_trans with (l := nil).
    trivial.

  - clear layered_top_trans.
    intros. gen S. dependent induction H; intros; eauto.
    1-5:induction l; eroutine.

    econstructor; eauto.
    specialize (IHsubtykn (cons typ_bot l) U eq_refl).
    simpl in IHsubtykn. auto.
Qed.
Local Hint Resolve trans_on_top.

Lemma trans_on_bot : forall L G T,
    [ L ] G ⊢k T <⦂ typ_bot ->
    forall U,
      [ L ] G ⊢k T <⦂ U
with layered_bot_trans : forall L G T l S,
    [ L ] G ⊢k T <⦂ bnd_layer (typ_bnd S typ_bot) l ->
    forall U,
      [ L ] G ⊢k T <⦂ bnd_layer (typ_bnd S U) l.
Proof.
  - clear trans_on_bot.
    dep induction on subtykn; eroutine.
    econstructor; eauto.
    apply layered_bot_trans with (l := nil).
    trivial.

  - clear layered_bot_trans.
    intros. gen U.
    dependent induction H; intros; eauto.
    1-5:induction l; eroutine.

    econstructor; eauto.
    specialize (IHsubtykn (cons typ_bot l) S eq_refl).
    simpl in IHsubtykn. auto.
Qed.
Local Hint Resolve trans_on_bot.

(** ** Soundness and Completeness of Step Subtyping w.r.t. Kernel D#<:# *)

(** Recall that there is an alternative definition of [Exposure], which is used here
    to serve as an intermediate setup to show the soundness theorem of kernel D#<:#.
 *)
Theorem exposure'_to_subtykn : forall G S U,
    exposure' G S U ->
    forall L U',
      [ L ] G ⊢k U <⦂ U' ->
      [ L ] G ⊢k S <⦂ U'.
Proof.
  induction on exposure'.
  1,2,4:eroutine.
  routine.
  econstructor; try eassumption.
  eauto.
Qed.

(** *** The soundness theorem *)
Theorem stp_subty_to_subtykn : forall L G S U,
    [ L ] G ⊢s S <⦂ U ->
    [ L ] G ⊢k S <⦂ U.
Proof.
  induction on stp_subty; routine.
  - destruct H; eauto.
    + econstructor. eauto.
      apply exposure_weakening with (G' := G2 ++ x ~ T) in H.
      rewrite app_assoc in H.
      apply exposure_to_exposure' in H.
      eapply exposure'_to_subtykn; eauto.
    + econstructor; eauto.
      apply exposure_weakening with (G' := G2 ++ x ~ T) in H.
      rewrite app_assoc in H.
      apply exposure_to_exposure' in H.
      eapply exposure'_to_subtykn; eauto.

  - destruct H; eauto.
    + econstructor. eauto.
      apply exposure_weakening with (G' := G2 ++ x ~ T) in H.
      rewrite app_assoc in H.
      apply exposure_to_exposure' in H.
      eapply exposure'_to_subtykn; eauto.
    + econstructor; eauto.
      apply exposure_weakening with (G' := G2 ++ x ~ T) in H.
      rewrite app_assoc in H.
      apply exposure_to_exposure' in H.
      eapply exposure'_to_subtykn; eauto.

  - eauto.
Qed.

(** *** The completeness theorem

    Similar to [Exposure], there is also a need to define alternative definitions of
[Upcast] and [Downcast]. *)
Inductive upcast_e' : env -> avar -> typ -> Prop :=
| ue_top : forall G x,
    upcast_e' G x typ_top
| ue_bot : forall G x T,
    binds x T G ->
    exposure' G T typ_bot ->
    upcast_e' G (avar_f x) typ_bot
| ue_bnd : forall G x T L U,
    binds x T G ->
    exposure' G T (typ_bnd L U) ->
    upcast_e' G (avar_f x) U.
Local Hint Constructors upcast_e'.

Inductive downcast_e' : env -> avar -> typ -> Prop :=
| de_bot : forall G x,
    downcast_e' G x typ_bot
| de_top : forall G x T,
    binds x T G ->
    exposure' G T typ_bot ->
    downcast_e' G (avar_f x) typ_top
| de_bnd : forall G x T L U,
    binds x T G ->
    exposure' G T (typ_bnd L U) ->
    downcast_e' G (avar_f x) L.
Local Hint Constructors downcast_e'.

(** Finally, we define a definition of step subtyping where the contexts are not
truncated. This is an intermediate setup to show completeness. *)
Inductive stp_subty' : vars -> env -> typ -> typ -> Prop :=
| ss'_top : forall L G T, stp_subty' L G T typ_top
| ss'_bot : forall L G T, stp_subty' L G typ_bot T
| ss'_sel_refl : forall L G x,
    stp_subty' L G (typ_sel x) (typ_sel x)
| ss'_sel_left : forall L G x T U,
    upcast_e' G x T ->
    stp_subty' L G T U ->
    stp_subty' L G (typ_sel x) U
| ss'_sel_right : forall L G x T U,
    downcast_e' G x T ->
    stp_subty' L G U T ->
    stp_subty' L G U (typ_sel x)
| ss'_bnd : forall L G S1 U1 S2 U2,
    stp_subty' L G S2 S1 ->
    stp_subty' L G U1 U2 ->
    stp_subty' L G (typ_bnd S1 U1) (typ_bnd S2 U2)
| ss'_all : forall L G T U1 U2 x,
    x `notin` fv G `union` fv T
      `union` fv U1 `union` fv U2 `union` L ->
    stp_subty' (L  `union` singleton x `union` fv T)
              (x ~ T ++ G) (open x U1) (open x U2) ->
    stp_subty' L G (typ_all T U1) (typ_all T U2).
Local Hint Constructors stp_subty' exposure'.

Program Fixpoint stp_subty'_refl T {measure (typ_struct_measure T)}
  : forall L G,
    stp_subty' L G T T := _.
Next Obligation.
  destruct T; eroutine.
  - pick_fresh x.
    econstructor.
    + instantiate (1 := x).
      auto.
    + apply stp_subty'_refl.
      rewrite open_typ_same_measure.
      lia.
  - constructor.
    all:apply stp_subty'_refl; lia.
Qed.
Local Hint Resolve stp_subty'_refl.

(** The following definition is a special definition of kernel D#<:#, where the steps of
derivations are accounted for as part of the judgments. Let us call this form
"step-enriched". This is necessary as we (mistakenly) define judgments in [Prop], which
cannot be eliminated into [Set] or [Type]. The steps of derivations are eventually
used in the well-foundness induction in the completeness theorem.  *)
Inductive subtykn' : vars -> env -> typ -> typ -> nat -> Prop :=
| snf'_refl : forall L G x, subtykn' L G (typ_sel x) (typ_sel x) 1
| snf'_top : forall L G T, subtykn' L G T typ_top 1
| snf'_bot : forall L G T, subtykn' L G typ_bot T 1
| snf'_bnd : forall L G S T1 T2 U n1 n2,
    subtykn' L G S T1 n1 -> subtykn' L G T2 U n2 ->
    subtykn' L G (typ_bnd T1 T2) (typ_bnd S U) (1 + n1 + n2)
| snf'_all : forall L G T U1 U2 x n,
    x `notin` union (fv G)
      (union (fv T) (union (fv U1) (union (fv U2) L))) ->
    subtykn' (union L (union (singleton x) (fv T)))
            (x ~ T ++ G) (open x U1) (open x U2) n ->
    subtykn' L G (typ_all T U1) (typ_all T U2) (1 + n)
| snf'_sel1 : forall L G x T S n,
    binds x T G ->
    subtykn' L G T (typ_bnd S typ_top) n ->
    subtykn' L G S (typ_sel $ avar_f x) (1 + n)
| snf'_sel2 : forall L G x T U n,
    binds x T G ->
    subtykn' L G T (typ_bnd typ_bot U) n ->
    subtykn' L G (typ_sel $ avar_f x) U (1 + n).
Hint Constructors subtykn'.
Notation "[ L , n ] G ⊢k S <⦂ U" := (subtykn' L G S U n) (at level 70).

Lemma subtykn_to_subtykn' : forall L G S U,
    [ L ] G ⊢k S <⦂ U ->
    exists n, [ L , n ] G ⊢k S <⦂ U.
Proof.
  induction on subtykn; eroutine.
Qed.

Lemma subtykn'_to_subtykn : forall L G S U n,
    [ L , n ] G ⊢k S <⦂ U ->
    [ L ] G ⊢k S <⦂ U.
Proof.
  induction on subtykn'; eroutine.
Qed.

(** It is quite straightforward to show the equivalence of kernel D#<:# and this
"step-enriched" definition of kernel D#<:#. *)
Lemma subtykn_equiv_subtykn' : forall L G S U,
    [ L ] G ⊢k S <⦂ U <->
    exists n, [ L , n ] G ⊢k S <⦂ U.
Proof.
  split; auto using subtykn_to_subtykn'.
  intros. tidy_up.
  eauto using subtykn'_to_subtykn.
Qed.

Local Hint Extern 1 (_ <= _) => lia.

(** This is the auxiliary lemma of completeness theorem. *)
Program Fixpoint subtykn'_conversions n {measure n} : forall L G S U,
    [ L , n ] G ⊢k S <⦂ U ->
    stp_subty' L G S U /\
    (forall T1 T2,
        U = typ_bnd T1 T2 ->
        exists S', exposure' G S S' /\
              (S' = typ_bot \/
               exists T1' T2' n',
                 S' = typ_bnd T1' T2' /\
                 stp_subty' L G T1 T1' /\
                 ([ L , n' ] G ⊢k T2' <⦂ T2) /\ n' <= n))
  := _.
Next Obligation.
  split; intros.
  - induction H; routine.
    + eapply ss'_all with x; auto.
    + clear IHsubtykn'.
      apply subtykn'_conversions in H0; auto.
      tidy_up.
      specialize (H1 _ _ eq_refl).
      tidy_up; eauto 10.
    + clear IHsubtykn'.
      apply subtykn'_conversions in H0; auto.
      tidy_up.
      specialize (H1 _ _ eq_refl).
      tidy_up; eauto.

      apply subtykn'_conversions in H8; auto.
      tidy_up. eauto.

  - destruct H; subst; progressive_inversions.
    + eroutine at 14.
    + eexists. split; [apply ex_stop; auto |].
      right. repeat eexists; try eassumption; auto.
      eapply subtykn'_conversions; try eassumption.
      lia.
    + apply subtykn'_conversions in H1; try lia.
      tidy_up.
      specialize (H1 _ _ eq_refl).
      tidy_up; eauto.

      apply subtykn'_conversions in H8; try lia.
      tidy_up.
      specialize (H6 _ _ eq_refl).
      tidy_up; eauto 14.
Qed.

(** At this step, we show that step subtyping is complete w.r.t. kernel D#<:# if
contexts are not truncated. The final step is to show that step subtyping performs the
same with and without the contexts truncated. *)
Theorem subtykn_to_stp_subty' : forall L G S U,
    [ L ] G ⊢k S <⦂ U ->
    stp_subty' L G S U.
Proof.
  intros.
  rewrite subtykn_equiv_subtykn' in *.
  tidy_up.
  eapply subtykn'_conversions.
  eauto.
Qed.

Local Hint Constructors stp_subty upcast_e downcast_e.
Local Hint Resolve exposure'_to_exposure.

Local Ltac wf_env :=
  lazymatch goal with
  | H : wf_env (_ ++ _) |- _ => apply wf_deapp in H; invert H; subst
  end.

Lemma upcast_e'_to_upcast_e : forall G x T,
    upcast_e' G x T ->
    wf_env G ->
    upcast_e G x T.
Proof.
  destr on upcast_e'; eroutine.
  all:apply binds_app in H; tidy_up;
    pose proof H1; wf_env.

  - eapply uce_bot.
    apply exposure_strengthening with (G2 := (H ++ x ~ T));
      try rewrite app_assoc in *; eauto.
  - eapply uce_bnd.
    apply exposure_strengthening with (G2 := (H ++ x ~ T));
      try rewrite app_assoc in *; eauto.
Qed.

Lemma downcast_e'_to_downcast_e : forall G x T,
    downcast_e' G x T ->
    wf_env G ->
    downcast_e G x T.
Proof.
  destr on downcast_e'; eroutine.
  all:apply binds_app in H; tidy_up;
    pose proof H1; wf_env.

  - eapply dce_top.
    apply exposure_strengthening with (G2 := (H ++ x ~ T));
      try rewrite app_assoc in *; eauto.
  - eapply dce_bnd.
    apply exposure_strengthening with (G2 := (H ++ x ~ T));
      try rewrite app_assoc in *; eauto.
Qed.

Local Hint Resolve upcast_e_preserves_wf upcast_e_preserves_lc upcast_e'_to_upcast_e.
Local Hint Resolve downcast_e_preserves_wf
      downcast_e_preserves_lc downcast_e'_to_downcast_e.

Lemma stp_subty'_to_stp_subty : forall L G S U,
    stp_subty' L G S U ->
    wf_env G ->
    fv S [<=] dom G -> lc S ->
    fv U [<=] dom G -> lc U ->
    [ L ] G ⊢s S <⦂ U.
Proof.
  induction on stp_subty'; intros; eauto.
  - econstructor.
    + apply upcast_e'_to_upcast_e; eassumption.
    + progressive_inversions.
      apply IHstp_subty'; eauto.
  - econstructor.
    + apply downcast_e'_to_downcast_e; eassumption.
    + progressive_inversions.
      apply IHstp_subty'; eauto.
  - progressive_inversions. simpl in *.
    fold_cls. auto 10.
  - progressive_inversions. simpl in *.
    invert H2; subst. fold_cls.
    apply ss_all with x; auto.
    apply IHstp_subty'.
    all:try apply open_lc_typ; trivial.
    + constructor; auto.
    + pose proof (fv_open_typ U1 x 0).
      etransitivity; [ eassumption |].
      set solve.
    + pose proof (fv_open_typ U2 x 0).
      etransitivity; [ eassumption |].
      set solve.
Qed.

(** The completeness theorem is thus established. *)
Theorem subtykn_to_stp_subty : forall L G S U,
    [ L ] G ⊢k S <⦂ U ->
    wf_env G ->
    fv S [<=] dom G -> lc S ->
    fv U [<=] dom G -> lc U ->
    [ L ] G ⊢s S <⦂ U.
Proof.
  intros.
  auto using subtykn_to_stp_subty', stp_subty'_to_stp_subty.
Qed.

Theorem subtykn_equiv_stp_subty : forall L G S U,
    wf_env G ->
    fv S [<=] dom G -> lc S ->
    fv U [<=] dom G -> lc U ->
    [ L ] G ⊢k S <⦂ U <->
    [ L ] G ⊢s S <⦂ U.
Proof.
  split; auto using subtykn_to_stp_subty, stp_subty_to_subtykn.
Qed.


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq ssralg.
(* Require Import path choice fintype tuple finset ssralg bigop poly polydiv. *)
(* Require Import ssrint ZArith. *)

From CoqEAL Require Import hrel param.

Require Import ssrmatching.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* Import GRing.Theory Pdiv.Ring Pdiv.CommonRing Pdiv.RingMonic. *)
Declare Scope computable_scope.
Delimit Scope computable_scope with C.
Local Open Scope rel.

(* Shortcut for triggering typeclass resolution *)
Ltac tc := do 1?typeclasses eauto.

Section refinements.

Fact refines_key : unit. Proof. done. Qed.
Class refines A B (R : A -> B -> Type) (m : A) (n : B) :=
  refines_rel : (locked_with refines_key R) m n.
Arguments refines A B R%rel m n.

Lemma refinesE A B (R : A -> B -> Type) : refines R = R.
Proof. by rewrite /refines unlock. Qed.

Lemma refines_eq T (x y : T) : refines eq x y -> x = y.
Proof. by rewrite refinesE. Qed.

#[export] Instance refines_bool_eq x y : refines bool_R x y -> refines eq x y.
Proof. by rewrite !refinesE=> [[]]. Qed.

Lemma nat_R_eq x y : nat_R x y -> x = y.
Proof. by elim=> // m n _ ->. Qed.

#[export] Instance refines_nat_eq x y : refines nat_R x y -> refines eq x y.
Proof. rewrite !refinesE; exact: nat_R_eq. Qed.

Lemma refinesP T T' (R : T -> T' -> Type) (x : T) (y : T') :
  refines R x y -> R x y.
Proof. by rewrite refinesE. Qed.

Fact composable_lock : unit. Proof. done. Qed.
Class composable A B C
  (rAB : A -> B -> Type) (rBC : B -> C -> Type) (rAC : A -> C -> Type) :=
  Composable : locked_with composable_lock (rAB \o rBC <= rAC).
Arguments composable A B C rAB%rel rBC%rel rAC%rel.

Lemma composableE A B C
 (rAB : A -> B -> Type) (rBC : B -> C -> Type) (rAC : A -> C -> Type) :
  composable rAB rBC rAC = (rAB \o rBC <= rAC).
Proof. by rewrite /composable unlock. Qed.

Lemma refines_trans A B C
  (rAB : A -> B -> Type) (rBC : B -> C -> Type) (rAC : A -> C -> Type)
  (a : A) (b : B) (c : C) : composable rAB rBC rAC ->
  refines rAB a b -> refines rBC b c -> refines rAC a c.
Proof.
by rewrite !refinesE composableE => rABC rab rbc; apply: rABC; exists b.
Qed.

Lemma trivial_refines T T' (R : T -> T' -> Type) (x : T) (y : T') :
  R x y -> refines R x y.
Proof. by rewrite refinesE. Qed.

#[export] Instance refines_apply
  A B (R : A -> B -> Type) C D (R' : C -> D -> Type) :
  forall (c : A -> C) (d : B -> D), refines (R ==> R') c d ->
  forall (a : A) (b : B), refines R a b -> refines R' (c a) (d b) | 99.
Proof. by rewrite !refinesE => c d rcd a b rab; apply: rcd. Qed.

#[export] Instance composable_rid1 A B (R : A -> B -> Type) :
  composable eq R R | 1.
Proof.
rewrite composableE; apply: eq_hrelRL.
by split; [ apply: comp_eql | move=> x y hxy; exists x ].
Qed.

#[export] Instance composable_bool_id1 B (R : bool -> B -> Type) :
  composable bool_R R R | 1.
Proof. by rewrite composableE => x y [y' [[]]]. Qed.

(* #[export] Instance composable_nat_id1 B (R : nat -> B -> Type) :
  composable nat_R R R | 1. *)
(* Proof. by rewrite composableE => x y [y' [/nat_R_eq ->]]. Qed. *)

#[export] Instance composable_comp A B C (rAB : A -> B -> Type)
  (rBC : B -> C -> Type) : composable rAB rBC (rAB \o rBC).
Proof. by rewrite composableE. Qed.

#[export] Instance composable_imply A B C A' B' C'
  (rAB : A -> B -> Type) (rBC : B -> C -> Type) (R1 : A' -> B' -> Type)
  (R2 : B' -> C' -> Type) (R3 : A' -> C' -> Type) : composable R1 R2 R3 ->
  composable (rAB ==> R1) (rBC ==> R2) (rAB \o rBC ==> R3) | 0.
Proof.
rewrite !composableE => R123 fA fC [fB [RfAB RfBC]] a c [b [rABab rBCbc]].
apply: R123; exists (fB b); split; [ exact: RfAB | exact: RfBC ].
Qed.

#[export] Instance composable_imply_id1 A B A' B' C'
  (rAB : A -> B -> Type) (R1 : A' -> B' -> Type) (R2 : B' -> C' -> Type)
  (R3 : A' -> C' -> Type) : composable R1 R2 R3 ->
  composable (eq ==> R1) (rAB ==> R2) (rAB ==> R3) | 1.
Proof.
rewrite !composableE => R123 fA fC [fB [RfAB RfBC]] a c rABac.
apply: R123; exists (fB a); split; [ exact: RfAB | exact: RfBC ].
Qed.

(* Composable and pairs *)
Lemma prod_RE A A' B B' (rA : A -> A' -> Type) (rB : B -> B' -> Type) x y :
  prod_R rA rB x y -> prod_hrel rA rB x y.
Proof. by case; split. Qed.

Lemma prod_RI A A' B B' (rA : A -> A' -> Type) (rB : B -> B' -> Type) x y :
  prod_hrel rA rB x y -> prod_R rA rB x y.
Proof. by move: x y => [x1 x2] [y1 y2] [] /=; constructor. Qed.

Lemma refines_prod_R A A' B B' (rA : A -> A' -> Type) (rB : B -> B' -> Type) x y :
  refines rA x.1 y.1 -> refines rB x.2 y.2 -> refines (prod_R rA rB) x y.
Proof. by rewrite !refinesE => *; apply: prod_RI; split. Qed.

#[export] Instance composable_prod A A' B B' C C'
  (rAB : A -> B -> Type) (rAB' : A' -> B' -> Type)
  (rBC : B -> C -> Type) (rBC' : B' -> C' -> Type)
  (rAC : A -> C -> Type) (rAC' : A' -> C' -> Type) :
    composable rAB rBC rAC ->
    composable rAB' rBC' rAC' ->
    composable (prod_R rAB rAB') (prod_R rBC rBC')
               (prod_R rAC rAC') | 1.
Proof.
rewrite !composableE=> h1 h2 [a a'] [c c'] [[b b']].
move=> [/prod_RE [/= ??] /prod_RE [/= ??]].
by split; [ apply: h1; exists b | apply: h2; exists b'].
Qed.

Section refines_split.
Context {T} {Y} {Z} {R1 : T -> Y -> Type} {R2 : Y -> Z -> Type} {x : T} {z : Z}.

Lemma refines_split :
  refines (R1 \o R2) x z -> {y : Y & (refines R1 x y * refines R2 y z)%type}.
Proof. by rewrite !refinesE. Qed.

Lemma refines_split1 :
  refines (R1 \o R2) x z -> {y : Y & (refines R1 x y * R2 y z)%type}.
Proof. by rewrite !refinesE. Qed.

Lemma refines_split2 :
  refines (R1 \o R2) x z -> {y : Y & (R1 x y * refines R2 y z)%type}.
Proof. by rewrite !refinesE. Qed.

Lemma refines_split12 :
  refines (R1 \o R2) x z -> {y : Y & (R1 x y * R2 y z)%type}.
Proof. by rewrite !refinesE. Qed.

End refines_split.

Lemma refines_abstr A B C D (R : A -> B -> Type) (R' : C -> D -> Type)
      (c : A -> C) (d : B -> D):
        (forall (a :  A) (b : B), refines R a b -> refines R' (c a) (d b)) ->
        refines (R ==> R') c d.
Proof. by rewrite !refinesE; apply. Qed.

Lemma refines_abstr2 A B A' B' A'' B''
      (R : A -> B -> Type) (R' : A' -> B' -> Type) (R'' : A'' -> B'' -> Type)
      (f : A -> A' -> A'' ) (g : B -> B' -> B''):
        (forall (a : A)   (b : B), refines R a b ->
         forall (a' : A') (b' : B'), refines R' a' b' ->
        refines R'' (f a a') (g b b')) ->
        refines (R ==> R' ==> R'') f g.
Proof. by move=> H; do 2![eapply refines_abstr => *]; apply: H. Qed.

#[export] Instance refines_pair_R
  A A' B B' (rA : A -> A' -> Type) (rB : B -> B' -> Type) :
  refines (rA ==> rB ==> prod_R rA rB)%rel (@pair _ _) (@pair _ _).
Proof. by rewrite refinesE. Qed.

#[export] Instance refines_fst_R
  A A' B B' (rA : A -> A' -> Type) (rB : B -> B' -> Type) :
  refines (prod_R rA rB ==> rA)%rel (@fst _ _) (@fst _ _).
Proof. by rewrite !refinesE=> [??] [??]. Qed.

#[export] Instance refines_snd_R
  A A' B B' (rA : A -> A' -> Type) (rB : B -> B' -> Type) :
  refines (prod_R rA rB ==> rB)%rel (@snd _ _) (@snd _ _).
Proof. by rewrite !refinesE=> [??] [??]. Qed.

Class unify A (x y : A) := unify_rel : x = y.
#[export] Instance unifyxx A (x : A) : unify x x := erefl.

#[export] Instance refines_of_unify A x y : unify x y -> refines (@unify A) x y | 100.
Proof. by rewrite refinesE. Qed.

Lemma refines_comp_unify A B (R : A -> B -> Type) x y :
  refines (R \o (@unify B))%rel x y -> refines R x y.
Proof. move=> /refines_split12.
  rewrite !refinesE=> H.
  case: H=> ? h.
  case: h=> ? h2.
  by rewrite -h2.
Qed.

End refinements.

Arguments refinesP {T T' R x y} _.

#[export] Hint Mode refines - - - + - : typeclass_instances.

#[export] Hint Extern 0 (refines _ _ _)
  => apply trivial_refines; eassumption : typeclass_instances.

#[export] Hint Extern 0 (refines (_ \o (@unify _))%rel _ _)
  => eapply refines_trans : typeclass_instances.

(* Tactic for doing parametricity proofs, it takes a parametricity
   theorem generated by the Parametricity plugin as argument *)
Ltac param x :=
  rewrite ?refinesE; do?move=> ?*;
  eapply x=> *; eapply refinesP;
  do ?eapply refines_apply; tc.

(* Special tactic when relation is defined using \o *)
Ltac param_comp x := eapply refines_trans; tc; param x.

#[export] Instance refines_true : refines _ _ _ :=
  trivial_refines bool_R_true_R.

#[export] Instance refines_false : refines _ _ _ :=
  trivial_refines bool_R_false_R.

#[export] Instance refines_negb : refines (bool_R ==> bool_R) negb negb.
Proof. exact/trivial_refines/negb_R. Qed.

#[export] Instance refines_implb : refines (bool_R ==> bool_R ==> bool_R) implb implb.
Proof. exact/trivial_refines/implb_R. Qed.

#[export] Instance refines_andb : refines (bool_R ==> bool_R ==> bool_R) andb andb.
Proof. exact/trivial_refines/andb_R. Qed.

#[export] Instance refines_orb : refines (bool_R ==> bool_R ==> bool_R) orb orb.
Proof. exact/trivial_refines/orb_R. Qed.

#[export] Instance refines_addb : refines (bool_R ==> bool_R ==> bool_R) addb addb.
Proof. exact/trivial_refines/addb_R. Qed.

#[export] Instance refines_eqb : refines (bool_R ==> bool_R ==> bool_R) eqtype.eq_op eqtype.eq_op.
Proof. exact/trivial_refines/eqb_R. Qed.

Lemma refines_goal (G G' : Type) : refines (fun T T' => T' -> T) G G' -> G' -> G.
Proof. by rewrite refinesE. Qed.

#[export] Instance refines_leibniz_eq (T : eqType) (x y : T) b :
  refines bool_R (x == y) b -> refines (fun T' T => T -> T') (x = y) b.
Proof. by move=> /refines_bool_eq; rewrite !refinesE => <- /eqP. Qed.

Module Refinements.

(* Generic operations *)
Module Op.

Class zero_of A := zero_op : A.
#[export] Hint Mode zero_of + : typeclass_instances.
Class one_of A := one_op : A.
#[export] Hint Mode one_of + : typeclass_instances.
Class opp_of A := opp_op : A -> A.
#[export] Hint Mode opp_of + : typeclass_instances.
Class add_of A := add_op : A -> A -> A.
#[export] Hint Mode add_of + : typeclass_instances.
Class sub_of A := sub_op : A -> A -> A.
#[export] Hint Mode sub_of + : typeclass_instances.
Class mul_of A := mul_op : A -> A -> A.
#[export] Hint Mode mul_of + : typeclass_instances.
Class exp_of A B := exp_op : A -> B -> A.
#[export] Hint Mode exp_of + + : typeclass_instances.
Class div_of A := div_op : A -> A -> A.
#[export] Hint Mode div_of + : typeclass_instances.
Class inv_of A := inv_op : A -> A.
#[export] Hint Mode inv_of + : typeclass_instances.
Class mod_of A := mod_op : A -> A -> A.
#[export] Hint Mode mod_of + : typeclass_instances.
Class scale_of A B := scale_op : A -> B -> B.
#[export] Hint Mode scale_of + + : typeclass_instances.

Class eq_of A := eq_op : A -> A -> bool.
#[export] Hint Mode eq_of + : typeclass_instances.
Class leq_of A := leq_op : A -> A -> bool.
#[export] Hint Mode leq_of + : typeclass_instances.
Class lt_of A := lt_op : A -> A -> bool.
#[export] Hint Mode lt_of + : typeclass_instances.
Class size_of A N := size_op : A -> N.
#[export] Hint Mode size_of + + : typeclass_instances.

Class spec_of A B   := spec : A -> B.
#[export] Hint Mode spec_of + + : typeclass_instances.
Definition spec_id {A : Type} : spec_of A A := id.
Class implem_of A B := implem : A -> B.
#[export] Hint Mode implem_of + + : typeclass_instances.
Definition implem_id {A : Type} : implem_of A A := id.
Class cast_of A B  := cast_op : A -> B.
#[export] Hint Mode cast_of + + : typeclass_instances.

End Op.
End Refinements.

Import Refinements.Op.

#[export]
Typeclasses Transparent zero_of one_of opp_of add_of sub_of mul_of exp_of div_of
            inv_of mod_of scale_of size_of eq_of leq_of lt_of spec_of implem_of cast_of.

Arguments spec / A B spec_of _: assert.

Notation "0"      := zero_op        : computable_scope.
Notation "1"      := one_op         : computable_scope.
Notation "-%C"    := opp_op.
Notation "- x"    := (opp_op x)     : computable_scope.
Notation "+%C"    := add_op.
Notation "x + y"  := (add_op x y)   : computable_scope.
Notation "x - y"  := (sub_op x y)   : computable_scope.
Notation "*%C"    := mul_op.
Notation "x * y"  := (mul_op x y)   : computable_scope.
Notation "x ^ y"  := (exp_op x y)   : computable_scope.
Notation "x %/ y" := (div_op x y)   : computable_scope.
Notation "x ^-1"  := (inv_op x)     : computable_scope.
Notation "x %% y" := (mod_op x y)   : computable_scope.
Notation "*:%C"   := scale_op.
Notation "x *: y" := (scale_op x y) : computable_scope.
Notation "x == y" := (eq_op x y)    : computable_scope.
Notation "x <= y" := (leq_op x y)   : computable_scope.
Notation "x < y"  := (lt_op x y)    : computable_scope.
Notation cast     := (@cast_op _).

Ltac simpC :=
  do ?[ rewrite -[0%C]/0%R
      | rewrite -[1%C]/1%R
      | rewrite -[(_ + _)%C]/(_ + _)%R
      | rewrite -[(_ + _)%C]/(_ + _)%N
      | rewrite -[(- _)%C]/(- _)%R
      | rewrite -[(_ - _)%C]/(_ - _)%R
      | rewrite -[(_ - _)%C]/(_ - _)%N
      | rewrite -[(_ * _)%C]/(_ * _)%R
      | rewrite -[(_ * _)%C]/(_ * _)%N
      | rewrite -[(_ %/ _)%C]/(_ %/ _)%R
      | rewrite -[(_ %% _)%C]/(_ %% _)%R
      | rewrite -[(_ == _)%C]/(_ == _)%bool
      ].

(* Section testmx. *)
(* Variable mxA : nat -> nat -> Type. *)
(* Definition idmx (m n : nat) (mx : mxA m n) : mxA m n := mx. *)
(* End testmx. *)
(* Parametricity idmx. *)
(* Print idmx_R. (* Here we get something too general! *) *)

(* Workaround because casts are not retained for hypothesis, so we
design this elimination lemma to abstract the context and vm_compute in the goal *)
Lemma abstract_context T (P : T -> Type) x : (forall Q, Q = P -> Q x) -> P x.
Proof. by move=> /(_ P); apply. Qed.

Tactic Notation  "context" "[" ssrpatternarg(pat) "]" tactic3(tac) :=
  let H := fresh "H" in let Q := fresh "Q" in let eqQ := fresh "eqQ" in
  ssrpattern pat => H;
  elim/abstract_context : (H) => Q eqQ; rewrite /H {H};
  tac; rewrite eqQ {Q eqQ}.

Class strategy_class (C : forall T, T -> T -> Prop) :=
   StrategyClass : C = @eq.
#[export] Hint Mode strategy_class + : typeclass_instances.

Class native_compute T (x y : T) := NativeCompute : x = y.
#[export] Hint Mode native_compute - + - : typeclass_instances.
#[export] Hint Extern 0 (native_compute _ _) =>
  context [(X in native_compute X)] native_compute; reflexivity :
  typeclass_instances.
#[export]
Instance strategy_class_native_compute : strategy_class native_compute := erefl.

Class vm_compute T (x y : T) := VmCompute : x = y.
#[export] Hint Mode vm_compute - + - : typeclass_instances.
#[export] Hint Extern 0 (vm_compute _ _) =>
  context [(X in vm_compute X)] vm_compute; reflexivity :
  typeclass_instances.
#[export]
Instance strategy_class_vm_compute : strategy_class vm_compute := erefl.

Class compute T (x y : T) := Compute : x = y.
#[export] Hint Mode compute - + - : typeclass_instances.
#[export] Hint Extern 0 (compute _ _) =>
  context [(X in compute X)] compute; reflexivity :
  typeclass_instances.
#[export] Instance strategy_class_compute : strategy_class compute := erefl.

Class simpl T (x y : T) := Simpl : x = y.
#[export] Hint Mode simpl - + - : typeclass_instances.
#[export] Hint Extern 0 (simpl _ _) =>
  context [(X in simpl X)] simpl; reflexivity :
  typeclass_instances.
#[export] Instance strategy_class_simpl : strategy_class simpl := erefl.

Lemma coqeal_eq C {eqC : strategy_class C} {T T'} spec (x x' : T) {y y' : T'}
   {rxy : refines eq (spec_id x) (spec y)}  {ry : C _ y y'}
   {rx : simpl (spec y') x'} : x = x'.
Proof. by rewrite eqC in ry; rewrite -rx -ry; apply: refines_eq. Qed.

Notation "'[' 'coqeal'  strategy  'of'  x ']'" :=
  (@coqeal_eq strategy _ _ _ _ x _ _ _ _ _ _).
Notation coqeal strategy := [coqeal strategy of _].
Notation "'[' 'coqeal'  strategy  'of'  x  'for'  y ']'" :=
  ([coqeal strategy of x] : y = _).

Ltac coqeal := apply: refines_goal; vm_compute.
Tactic Notation "coqeal_" tactic3(tac) :=  apply: refines_goal; tac.
Tactic Notation "coqeal" "[" ssrpatternarg(pat) "]" open_constr(strategy) :=
  let H := fresh "H" in let Q := fresh "Q" in let eqQ := fresh "eqQ" in
  ssrpattern pat => H; elim/abstract_context : (H) => Q eqQ;
  rewrite /H {H} [(X in Q X)](coqeal strategy) eqQ {Q eqQ}.

Ltac refines_apply1 := eapply refines_apply; tc.
Ltac refines_abstr1 := eapply refines_abstr=> ???; tc.
Ltac refines_apply := do ![refines_apply1].
Ltac refines_abstr := do ![refines_abstr1].
Ltac refines_trans :=  eapply refines_trans; tc.

(** Automation: for proving refinement lemmas involving if-then-else's
do [rewrite !ifE; apply refines_if_expr]. *)
Lemma refines_if_expr
  (A C : Type) (b1 b2 : bool) (vt1 vf1 : A) (vt2 vf2 : C) (R : A -> C -> Type) :
  refines bool_R b1 b2 -> (b1 -> b2 -> R vt1 vt2) -> (~~ b1 -> ~~ b2 -> R vf1 vf2) ->
  refines R (if_expr b1 vt1 vf1) (if_expr b2 vt2 vf2).
Proof.
move/refines_bool_eq/refinesP=> Hb; rewrite -!{}Hb => Ht Hf.
rewrite /if_expr !refinesE; case: b1 Ht Hf => Ht Hf.
exact: Ht.
exact: Hf.
Qed.

Lemma optionE (A B : Type) (o : option A) (b : B) (f : A -> B) :
  match o with
  | Some a => f a
  | None => b
  end = oapp f b o.
Proof. by []. Qed.

(** Automation: for proving refinement lemmas involving options,
do [rewrite !optionE; refines_apply]. *)
#[export] Instance refines_option
  (A B : Type) (rA : A -> A -> Type) (rB : B -> B -> Type) :
  refines ((rA ==> rB) ==> rB ==> option_R rA ==> rB) (@oapp _ _) (@oapp _ _).
Proof.
rewrite refinesE => f1 f2 Hf b1 b2 Hb o1 o2 Ho.
case: o1 Ho => [a1|]; case: o2 => [a2|] Ho //=.
{ eapply refinesP; refines_apply; rewrite refinesE in Ho *.
  by inversion_clear Ho. }
{ by eapply refinesP; inversion_clear Ho. }
{ by eapply refinesP; inversion_clear Ho. }
Qed.


Require Import Coq.Classes.RelationClasses.

Require Import SpecCert.x86.Architecture.
Require Import SpecCert.x86.Event.

Definition dummy_secure {S :Set} :=
  fun (a:Architecture S) =>
    True.

Definition exec_sec
           {S       :Set}
           {lt      :S -> S -> Prop}
           (context :ProcessorUnit -> S)
           (policy  :StrictOrder lt)
           (o       :S):=
  fun (a:Architecture S) =>
    let current_context := context (proc a) in
    lt current_context o \/ current_context = o.

Definition secure_transition
           {S       :Set}
           {lt      :S -> S -> Prop}
           (context :ProcessorUnit -> S)
           (policy  :StrictOrder lt)
           (a       :Architecture S)
           (ev      :Event S) :=
  match ev with
  | hardware (Exec o) => exec_sec context policy o a
  | _ => dummy_secure a
  end.