Add LoadPath "..".
Require Import LF_Syntax.
Require Import LF_Substitution.
Require Import LF_OkLib.
Require Import LF_EmptyEquivLib.

Open Scope permut_scope.
Open Scope is5_scope.

Reserved Notation " G  '|=' Gamma '|-' M ':::' A" (at level 70).

Inductive types_LF : bg_LF -> ctx_LF -> te_LF -> ty -> Prop :=

| t_hyp_LF: forall A G Gamma v
  (Ok: ok_Bg_LF (Gamma::G))
  (H: Mem (v, A) Gamma),
  G |= Gamma |- hyp_LF (fte v) ::: A

| t_lam_LF: forall L A B G Gamma M
  (Ok: ok_Bg_LF (Gamma::G))
  (H: forall v, v \notin L ->
    G |= (v, A)::Gamma |- M ^t^ (hyp_LF (fte v)) ::: B),
  G |= Gamma |- lam_LF A M ::: A ---> B

| t_appl_LF: forall A B G Gamma M N
  (Ok: ok_Bg_LF (Gamma::G))
  (H1: G |= Gamma |- M ::: A ---> B)
  (H2: G |= Gamma |- N ::: A),
  G |= Gamma |- appl_LF M N ::: B

| t_box_LF: forall G Gamma M A
  (Ok: ok_Bg_LF (G & Gamma))
  (H: G & Gamma |= nil |- M ::: A),
  G |= Gamma |- box_LF M ::: [*] A

| t_unbox_LF: forall G Gamma M A
  (Ok: ok_Bg_LF (Gamma :: G))
  (H: G |= Gamma |- M ::: [*] A),
  G |= Gamma |- unbox_LF M ::: A

| t_unbox_fetch_LF: forall G Gamma Gamma' M A
  (Ok: ok_Bg_LF (Gamma:: G & Gamma'))
  (H: G & Gamma' |= Gamma |- M ::: [*] A),
  forall G', G & Gamma ~=~ G' ->
    G' |= Gamma' |- unbox_LF M ::: A

| t_here_LF: forall A G Gamma M
  (Ok: ok_Bg_LF (Gamma :: G))
  (H: G |= Gamma |- M ::: A),
  G |= Gamma |- here_LF M ::: <*> A

| t_get_here_LF: forall A G Gamma Gamma' M
  (Ok: ok_Bg_LF (Gamma :: G & Gamma'))
  (H: G & Gamma' |= Gamma |- M ::: A),
  forall G', G & Gamma ~=~ G' ->
    G' |= Gamma' |- here_LF M ::: <*> A

| t_letdia_LF: forall L A B G Gamma M N
  (Ok: ok_Bg_LF (Gamma :: G))
  (HT1: G |= Gamma |- M ::: <*> A)
  (HT2: forall G' v, v \notin L ->
    ((v, A) :: nil) :: G ~=~ G' ->
    G' |= Gamma |- N ^t^ (hyp_LF (fte v)) ::: B),
  G |= Gamma |- letdia_LF M N ::: B

| t_letdia_get_LF: forall L A B G Gamma Gamma' M N
  (Ok: ok_Bg_LF (Gamma :: G & Gamma'))
  (HT1: G & Gamma' |= Gamma |- M ::: <*> A)
  (HT2: forall v, v \notin L ->
    ((v, A) :: nil) :: G & Gamma |= Gamma' |-
      N ^t^ (hyp_LF (fte v))::: B),
  forall G0, G & Gamma ~=~ G0 ->
    G0 |= Gamma' |- letdia_LF M N ::: B

where " G '|=' Gamma '|-' M ':::' A" := (types_LF G Gamma M A).

Inductive value_LF: te_LF -> Prop :=
| val_lam_LF: forall A M, value_LF (lam_LF A M)
| val_box_LF: forall M, value_LF (box_LF M)
| val_here_LF: forall M, value_LF M -> value_LF (here_LF M)
.

Reserved Notation " M |-> N " (at level 70).

Inductive step_LF: te_LF -> te_LF -> Prop :=

| red_appl_lam_LF: forall M N A,
  lc_t_n_LF 1 M -> lc_t_LF N ->
  appl_LF (lam_LF A M) N |-> [N // bte 0] M

| red_unbox_box_LF: forall M,
  lc_t_LF M ->
  unbox_LF (box_LF M)|-> M

| red_letdia_here_LF: forall M N,
  lc_t_LF M -> lc_t_n_LF 1 N -> value_LF M ->
  letdia_LF (here_LF M) N |-> N ^t^ M

| red_appl_LF: forall M M' N,
  lc_t_LF M -> lc_t_LF N ->
  M |-> M'->
  appl_LF M N |-> appl_LF M' N

| red_unbox_LF: forall M M',
  lc_t_LF M -> M |-> M' ->
  unbox_LF M |-> unbox_LF M'

| red_here_LF: forall M M' ,
  lc_t_LF M -> M |-> M' ->
  here_LF M |-> here_LF M'

| red_letdia_LF: forall M M' N,
  lc_t_LF M -> lc_t_n_LF 1 N ->
  M |-> M'->
  letdia_LF M N |-> letdia_LF M' N

where " M |-> N " := (step_LF M N ).

Inductive steps_LF : te_LF -> te_LF -> Prop :=
| single_step_LF: forall M M', M |-> M' -> steps_LF M M'
| multi_step_LF: forall M M' M'',
  M |-> M' -> steps_LF M' M'' -> steps_LF M M''
.

Lemma PPermutationG_LF:
forall G Gamma M A G',
  G |= Gamma |- M ::: A ->
  G ~=~ G' ->
  G' |= Gamma |- M ::: A.
intros; generalize dependent G'; induction H; intros; simpl in *.

constructor; [apply ok_Bg_LF_PPermut with (G:=Gamma::G)| ]; auto;
PPermut_LF_simpl.

apply t_lam_LF with (L:=L);
[apply ok_Bg_LF_PPermut with (G:=Gamma::G)| ]; auto; PPermut_LF_simpl.

apply t_appl_LF with (A:=A);
[apply ok_Bg_LF_PPermut with (G:=Gamma::G)| |]; auto; PPermut_LF_simpl.

constructor;
[apply ok_Bg_LF_PPermut with (G:=G & Gamma)|]; auto.

constructor;
[apply ok_Bg_LF_PPermut with (G:=Gamma::G)|]; auto.

apply t_unbox_fetch_LF with (G:=G) (Gamma:=Gamma); auto. rewrite H0; auto.

constructor;
[apply ok_Bg_LF_PPermut with (G:=Gamma::G)|]; auto.

apply t_get_here_LF with (G:=G) (Gamma:=Gamma); auto. rewrite H0; auto.

apply t_letdia_LF with (A:=A) (L:=L);
[apply ok_Bg_LF_PPermut with (G:=Gamma::G) | | ]; auto.
intros; apply HT2; auto. rewrite H1; auto.

apply t_letdia_get_LF with (A:=A) (L:=L) (G:=G) (Gamma:=Gamma);
[apply ok_Bg_LF_PPermut with (G:=Gamma::G & Gamma') | | | ]; auto.
rewrite <- H2; auto.
Qed.

Lemma PermutationGamma_LF:
forall G Gamma M A Gamma',
  G |= Gamma |- M ::: A ->
  Gamma *=* Gamma' ->
  G |= Gamma' |- M ::: A.
intros. generalize dependent Gamma'.
induction H; intros; simpl in *.

constructor;
[apply ok_Bg_LF_PPermut with (G:=Gamma::G) |
 apply Mem_permut with (l:=Gamma)]; auto.

apply t_lam_LF with (L:=L);
[apply ok_Bg_LF_PPermut with (G:=Gamma::G) |]; auto.

apply t_appl_LF with (A:=A);
[apply ok_Bg_LF_PPermut with (G:=Gamma::G) | |]; auto.

constructor;
[apply ok_Bg_LF_PPermut with (G:=G & Gamma) |]; auto.
apply PPermutationG_LF with (G:=G & Gamma);
auto.

constructor;
[apply ok_Bg_LF_PPermut with (G:= Gamma :: G) |]; auto.

apply t_unbox_fetch_LF with (G:=G) (Gamma:=Gamma);
[apply ok_Bg_LF_PPermut with (G:= Gamma :: G & Gamma') | |]; auto.
apply PPermutationG_LF with (G:=G & Gamma'); auto.

constructor;
[apply ok_Bg_LF_PPermut with (G:= Gamma :: G) |]; auto.

apply t_get_here_LF with (G:=G) (Gamma:=Gamma);
[apply ok_Bg_LF_PPermut with (G:= Gamma :: G & Gamma') | |]; auto.
apply PPermutationG_LF with (G:=G & Gamma'); auto.

apply t_letdia_LF with (A:=A) (L:=L);
[apply ok_Bg_LF_PPermut with (G:= Gamma :: G) | |]; auto.

apply t_letdia_get_LF with (A:=A) (L:=L) (G:=G) (Gamma:=Gamma);
[apply ok_Bg_LF_PPermut with (G:= Gamma :: G & Gamma') | | |]; auto.
apply PPermutationG_LF with (G:=G & Gamma'); auto.
Qed.

Add Morphism types_LF: PPermut_LF_types.
split; intros.
eapply PermutationGamma_LF; eauto; eapply PPermutationG_LF; eauto.
apply PermutationGamma_LF with (Gamma:=y0); [ | symmetry ]; eauto;
eapply PPermutationG_LF; eauto.
Qed.

Lemma WeakeningG_LF:
forall G Gamma M A Delta,
  G |= Gamma |- M ::: A ->
  ok_Bg_LF (Gamma::Delta::G) ->
  Delta :: G |= Gamma |- M ::: A.
intros; generalize dependent Delta; induction H;
intros; simpl in *; eauto using types_LF.

apply t_lam_LF with (L:=L \u used_vars_ctx_LF (Gamma:: Delta :: G));
auto; intros;
apply H0; auto; apply ok_Bg_LF_fresh; auto;
apply notin_Mem; rewrite notin_union in H2; destruct H2; auto.

constructor;
[apply ok_Bg_LF_PPermut with (G:=Gamma::Delta::G) | rew_app ];
auto. rew_app; PPermut_LF_simpl. apply IHtypes_LF; apply ok_Bg_LF_nil;
apply ok_Bg_LF_PPermut with (G:=Gamma::Delta::G); auto. PPermut_LF_simpl.

apply t_unbox_fetch_LF with (Gamma:=Gamma) (G:=Delta :: G);
[apply ok_Bg_LF_PPermut with (G:=Gamma'::Delta::G') | |]; auto;
rew_app. rewrite <- H0; PPermut_LF_simpl.
apply IHtypes_LF; eapply ok_Bg_LF_PPermut; eauto.
rewrite <- H0; PPermut_LF_simpl. rewrite H0; auto.

apply t_get_here_LF with (Gamma:=Gamma) (G:=Delta :: G);
[apply ok_Bg_LF_PPermut with (G:=Gamma'::Delta::G') | |]; auto.
rewrite <- H0; rew_app; PPermut_LF_simpl.
rew_app; apply IHtypes_LF; eapply ok_Bg_LF_PPermut; eauto.
rewrite <- H0; PPermut_LF_simpl.
rewrite <- H0; PPermut_LF_simpl.

apply t_letdia_LF with
  (L:=L \u used_vars_ctx_LF (Gamma :: Delta :: G)) (A:=A);
auto; intros.
apply PPermutationG_LF with (G:=Delta :: ((v, A)::nil) :: G).
apply H0; auto.
apply ok_Bg_LF_PPermut with (G:=((v,A)::nil) :: Gamma :: Delta :: G).
apply ok_Bg_LF_fresh; [apply ok_Bg_LF_nil | ]; auto.
unfold used_vars_ctx_LF in *; rew_concat in *; eauto.
PPermut_LF_simpl. rewrite <- H3; PPermut_LF_simpl.

apply t_letdia_get_LF with
  (L:=L \u from_list (map fst (Gamma' ++ Delta ++ concat G0)))
  (A:=A) (G:=Delta::G) (Gamma:=Gamma);
[apply ok_Bg_LF_PPermut with (G:=Gamma'::Delta::G0) | | |]; auto.
rewrite <- H1; PPermut_LF_simpl.
apply IHtypes_LF;
apply ok_Bg_LF_PPermut with (G:=Gamma'::Delta::G0); auto.
rewrite <- H1; PPermut_LF_simpl.
intros; apply PPermutationG_LF with (G:=Delta :: ((v, A) :: nil) :: G & Gamma).
apply H0; auto.
apply ok_Bg_LF_PPermut with (G:= ((v, A)::nil) :: Gamma' :: Delta :: G0).
apply ok_Bg_LF_fresh; [apply ok_Bg_LF_nil | ]; auto.
unfold used_vars_ctx_LF in *; rew_concat in *; eauto.
rewrite notin_union in H3; destruct H3; auto.
rewrite H1; PPermut_LF_simpl.
rew_app; PPermut_LF_simpl.
rewrite <- H1; PPermut_LF_simpl.
Qed.

Lemma WeakeningWithinContext_LF:
forall G Gamma M A,
  G |= Gamma |- M ::: A ->
  (forall Delta Delta' G',
    G' & Delta ~=~ G ->
    ok_Bg_LF (Gamma :: G' & (Delta ++ Delta')) ->
    G' & (Delta++Delta') |= Gamma |- M ::: A)
  /\
  (forall Gamma',
    ok_Bg_LF ((Gamma++Gamma')::G) ->
    G |= Gamma ++ Gamma' |- M ::: A).
intros G Gamma M A H;
induction H; split; intros; subst.
constructor; auto.
constructor; auto; rewrite Mem_app_or_eq; left; auto.
apply t_lam_LF with
  (L:=L \u
    (used_vars_ctx_LF (Gamma :: G' & (Delta ++ Delta'))));
auto; intros; eapply H0; eauto;
rew_app; apply ok_Bg_LF_fresh; eauto; apply notin_Mem;
rewrite notin_union in H3; destruct H3; auto.
apply t_lam_LF with
  (L:=L \u
    (used_vars_ctx_LF ((Gamma ++ Gamma') :: G)));
auto; intros; eapply H0; eauto;
rew_app; apply ok_Bg_LF_fresh; eauto;
rewrite notin_union in H2; destruct H2; auto.
econstructor; eauto; [eapply IHtypes_LF1 | eapply IHtypes_LF2]; eauto.
econstructor; eauto; [eapply IHtypes_LF1 | eapply IHtypes_LF2]; eauto.
econstructor;
[apply ok_Bg_LF_PPermut with (G:=Gamma:: G' & (Delta++Delta')) | ];
auto. PPermut_LF_simpl.
apply PPermutationG_LF with (G:= ((G'& Gamma) & (Delta ++ Delta'))).
eapply IHtypes_LF. rewrite <- H0; PPermut_LF_simpl.
apply ok_Bg_LF_nil; apply ok_Bg_LF_PPermut
  with (G:=Gamma :: G' & (Delta ++ Delta'));
auto. PPermut_LF_simpl.
econstructor;
[apply ok_Bg_LF_PPermut with (G:=(Gamma++Gamma'):: G) | ];
auto. PPermut_LF_simpl.
eapply IHtypes_LF; auto.
apply ok_Bg_LF_nil; apply ok_Bg_LF_PPermut with (G:=(Gamma++Gamma') :: G);
auto. PPermut_LF_simpl.
constructor; eauto; eapply IHtypes_LF; eauto.
constructor; eauto; eapply IHtypes_LF; eauto.
assert (Delta::G'0 ~=~ G & Gamma).
  transitivity G'; auto; rewrite <- H1; PPermut_LF_simpl.
assert ({Gamma *=* Delta} + {~ Gamma *=* Delta}).
  eapply permut_dec; intros; destruct k; destruct k'; repeat decide equality.
  apply eq_var_dec.
destruct H4.
(* Gamma *=* Delta *)
assert (G'0 ~=~ G).
  apply PPermut_LF_last_rev with (Gamma:=Delta) (Gamma':=Gamma).
  symmetry; auto.
  rewrite <- H3; PPermut_LF_simpl.
apply t_unbox_fetch_LF with (G:=G'0) (Gamma:=Delta++Delta'); auto.
apply ok_Bg_LF_PPermut with (G:=Gamma'::G'0&(Delta++Delta')); auto.
apply PPermutationG_LF with (G:=G & Gamma'); auto.
apply PermutationGamma_LF with (Gamma:=Gamma++Delta'); auto.
eapply IHtypes_LF.
apply ok_Bg_LF_PPermut with (G:=Gamma'::G'0&(Delta++Delta')); auto.
rewrite H4; PPermut_LF_simpl.
(* ~ Gamma *=* Delta *)
assert (G'0 & Delta ~=~ G & Gamma) by (rewrite <- H3; PPermut_LF_simpl).
apply PPermut_LF_split_neq in H4; [ | intro; elim n; symmetry; auto];
destruct H4 as (Gamma0, (hd, (tl, (H4, H5)))).
subst.
apply t_unbox_fetch_LF with (G:=hd++tl & (Delta++Delta')) (Gamma:=Gamma).
apply ok_Bg_LF_PPermut
  with (G:=Gamma' :: (hd & Gamma0 ++ tl) & (Delta ++ Delta'));
auto; rew_app; PPermut_LF_simpl.
apply PPermutationG_LF with (G:=(hd& Gamma' ++ tl) & (Delta ++ Delta')).
eapply IHtypes_LF. rew_app; PPermut_LF_simpl.
apply PPermut_LF_last_rev with (Gamma:=Gamma0) (Gamma':=Gamma); auto;
rewrite <- H3; PPermut_LF_simpl.
apply ok_Bg_LF_PPermut
  with (G:=Gamma' :: (hd & Gamma0 ++ tl) & (Delta ++ Delta'));
auto; rew_app; PPermut_LF_simpl.
rew_app; PPermut_LF_simpl.
rew_app; PPermut_LF_simpl.
apply t_unbox_fetch_LF with (G:=G) (Gamma:=Gamma);
[apply ok_Bg_LF_PPermut with (G:=(Gamma'++Gamma'0):: G') | | ];
auto. rewrite <- H0; PPermut_LF_simpl.
eapply IHtypes_LF; auto.
apply ok_Bg_LF_PPermut with (G:=(Gamma'++Gamma'0):: G'); auto.
rewrite <- H0; PPermut_LF_simpl.
constructor; eauto; eapply IHtypes_LF; eauto.
constructor; eauto; eapply IHtypes_LF; eauto.
assert (G & Gamma ~=~ G'0 & Delta) by (rewrite  H1; auto).
assert ({Gamma *=* Delta} + {~ Gamma *=* Delta}).
  eapply permut_dec; intros; destruct k; destruct k'; repeat decide equality;
  apply eq_var_dec.
destruct H4.
(* Gamma *=* Delta *)
assert (G'0 ~=~ G).
  apply PPermut_LF_last_rev with (Gamma:=Delta) (Gamma':=Gamma).
  symmetry; auto.
  rewrite <- H3; PPermut_LF_simpl.
apply t_get_here_LF with (G:=G'0) (Gamma:=Delta++Delta'); auto.
apply ok_Bg_LF_PPermut with (G:=Gamma'::G'0&(Delta++Delta')); auto.
apply PPermutationG_LF with (G:=G & Gamma'); auto.
apply PermutationGamma_LF with (Gamma:=Gamma++Delta'); auto.
eapply IHtypes_LF.
apply ok_Bg_LF_PPermut with (G:=Gamma'::G'0&(Delta++Delta')); auto.
rewrite H4; PPermut_LF_simpl.
(* ~ Gamma *=* Delta *)
assert (G'0 & Delta ~=~ G & Gamma) by (rewrite <- H3; PPermut_LF_simpl).
apply PPermut_LF_split_neq in H4; [ | intro; elim n; symmetry; auto];
destruct H4 as (Gamma0, (hd, (tl, (H4, H5)))).
subst.
apply t_get_here_LF with (G:=hd++tl & (Delta++Delta')) (Gamma:=Gamma).
apply ok_Bg_LF_PPermut
  with (G:=Gamma' :: (hd & Gamma0 ++ tl) & (Delta ++ Delta'));
auto; rew_app; PPermut_LF_simpl.
apply PPermutationG_LF with (G:=(hd& Gamma' ++ tl) & (Delta ++ Delta')).
eapply IHtypes_LF. rew_app; PPermut_LF_simpl.
apply PPermut_LF_last_rev with (Gamma:=Gamma0) (Gamma':=Gamma); auto.
rewrite H3; PPermut_LF_simpl.
apply ok_Bg_LF_PPermut
  with (G:=Gamma' :: (hd & Gamma0 ++ tl) & (Delta ++ Delta'));
auto; rew_app; PPermut_LF_simpl.
rew_app; PPermut_LF_simpl.
rew_app; PPermut_LF_simpl.
apply t_get_here_LF with (G:=G) (Gamma:=Gamma);
[apply ok_Bg_LF_PPermut with (G:=(Gamma'++Gamma'0):: G') | | ];
auto. rewrite <- H0; PPermut_LF_simpl.
eapply IHtypes_LF. auto.
apply ok_Bg_LF_PPermut with (G:=(Gamma'++Gamma'0):: G'); auto. rewrite <- H0;
PPermut_LF_simpl.
apply t_letdia_LF with (A:=A)
  (L:=L \u (used_vars_ctx_LF (Gamma :: G' & (Delta ++ Delta'))));
auto; [apply IHtypes_LF | intros]; auto.
apply PPermutationG_LF with (G:= (((v, A) :: nil) :: G') & (Delta ++ Delta')).
eapply H0 with (G':=((v, A)::nil) :: G' & Delta).
auto. rewrite H1; rew_app; PPermut_LF_simpl. rew_app; PPermut_LF_simpl.
apply ok_Bg_LF_PPermut
  with (G:=((v, A) :: nil) :: Gamma :: G' & (Delta ++Delta')).
apply ok_Bg_LF_fresh. apply ok_Bg_LF_nil; auto.
unfold used_vars_ctx_LF in *; rew_concat in *; eauto.
rew_app; PPermut_LF_simpl.
rew_app; auto.
apply t_letdia_LF with (A:=A)
  (L:=L \u (used_vars_ctx_LF ((Gamma++Gamma') :: G)));
auto; [apply IHtypes_LF | intros]; auto.
eapply H0; eauto.
apply ok_Bg_LF_PPermut with (G:=((v, A) :: nil) :: (Gamma++Gamma') :: G).
apply ok_Bg_LF_fresh. apply ok_Bg_LF_nil; auto.
unfold used_vars_ctx_LF in *; rew_concat in *; eauto.
rewrite <- H3; PPermut_LF_simpl.
assert (Gamma::G ~=~ G' & Delta).
  transitivity G0; auto; rewrite <- H1; PPermut_LF_simpl.
assert ({Gamma *=* Delta} + {~ Gamma *=* Delta}).
  eapply permut_dec; intros; destruct k; destruct k'; repeat decide equality.
  apply eq_var_dec.
destruct H5.
(* Gamma *=* Delta *)
assert (G ~=~ G').
  apply PPermut_LF_last_rev with (Gamma:=Gamma) (Gamma':=Delta).
  auto.
  rewrite <- H4; PPermut_LF_simpl.
apply t_letdia_get_LF with (A:=A)
(L:=L \u used_vars_ctx_LF (nil :: Gamma' :: G' & (Delta ++ Delta'))) (G:=G')
(Gamma:=Delta++Delta'); auto.
apply ok_Bg_LF_PPermut with (G:=Gamma'::G'&(Delta++Delta')); auto.
apply PPermutationG_LF with (G:=G & Gamma'); auto.
apply PermutationGamma_LF with (Gamma:=Gamma++Delta'); auto.
eapply IHtypes_LF.
apply ok_Bg_LF_PPermut with (G:=Gamma'::G'&(Delta++Delta')); auto.
rewrite H5; PPermut_LF_simpl.
intros; destruct H0 with (v:=v); auto.
apply PPermutationG_LF with (G:=((((v, A) :: nil) :: G') & (Delta ++ Delta'))).
eapply H7. rewrite H5; PPermut_LF_simpl.
apply ok_Bg_LF_PPermut with (G:=((v,A)::nil)::Gamma' :: G' & (Delta ++ Delta')).
apply ok_Bg_LF_fresh. auto. rewrite notin_union in H6; destruct H6. auto.
PPermut_LF_simpl. PPermut_LF_simpl.
(* ~ Gamma *=* Delta *)
assert (G' & Delta ~=~ G & Gamma) by (rewrite <- H4; PPermut_LF_simpl).
apply PPermut_LF_split_neq in H5; [ | intro; elim n; symmetry; auto];
destruct H5 as (Gamma0, (hd, (tl, (H5, H6)))).
subst.
apply t_letdia_get_LF with (G:=hd++tl & (Delta++Delta')) (Gamma:=Gamma)
 (L:=L \u used_vars_ctx_LF
     (nil :: Gamma' :: (hd & Gamma0 ++ tl) & (Delta ++ Delta'))) (A:=A).
apply ok_Bg_LF_PPermut
  with (G:=Gamma' :: (hd & Gamma0 ++ tl) & (Delta ++ Delta'));
auto; rew_app; PPermut_LF_simpl.
apply PPermutationG_LF with (G:=(hd& Gamma' ++ tl) & (Delta ++ Delta')).
eapply IHtypes_LF. rew_app; PPermut_LF_simpl.
apply PPermut_LF_last_rev with (Gamma:=Gamma0) (Gamma':=Gamma); auto.
transitivity (Gamma::G); auto. rewrite H4; PPermut_LF_simpl. PPermut_LF_simpl.
apply ok_Bg_LF_PPermut
  with (G:=Gamma' :: (hd & Gamma0 ++ tl) & (Delta ++ Delta'));
auto; rew_app; PPermut_LF_simpl.
rew_app; PPermut_LF_simpl.
intros; destruct H0 with (v:=v); auto.
apply PPermutationG_LF with (G:=((((v, A) :: nil) :: Gamma0:: hd++tl) &
  (Delta ++ Delta'))).
eapply H7. PPermut_LF_simpl; transitivity (Gamma::G); auto.
rewrite H4; PPermut_LF_simpl. PPermut_LF_simpl.
apply ok_Bg_LF_PPermut with (G:=((v,A)::nil)::Gamma' ::
  (hd & Gamma0 ++ tl) & (Delta ++ Delta')).
apply ok_Bg_LF_fresh. auto. rewrite notin_union in H6; destruct H6. auto.
rew_app; PPermut_LF_simpl. rew_app; PPermut_LF_simpl.
rew_app; PPermut_LF_simpl.
apply t_letdia_get_LF with (A:=A) (G:=G) (Gamma:=Gamma)
  (L:=L \u (used_vars_ctx_LF ((Gamma' ++ Gamma'0) :: G0)));
[apply ok_Bg_LF_PPermut with (G:=(Gamma'++Gamma'0):: G0) | | | ];
auto.  rewrite <- H1; PPermut_LF_simpl.
eapply IHtypes_LF. auto.
apply ok_Bg_LF_PPermut with (G:=(Gamma'++Gamma'0):: G0); auto. rewrite <- H1;
PPermut_LF_simpl.
intros. eapply H0; eauto.
apply ok_Bg_LF_PPermut with (G:=((v,A)::nil) :: (Gamma'++Gamma'0) :: G0).
apply ok_Bg_LF_fresh. apply ok_Bg_LF_nil; auto.
unfold used_vars_ctx_LF in *; rew_concat in *; eauto.
rewrite <- H1; PPermut_LF_simpl.
Qed.

Lemma WeakeningGamma_LF:
forall G Gamma M A Gamma',
  G |= Gamma |- M ::: A ->
  ok_Bg_LF ((Gamma++Gamma')::G) ->
  G |= Gamma ++ Gamma' |- M ::: A.
intros; eapply WeakeningWithinContext_LF; eauto.
Qed.

Lemma WeakeningWithinG:
forall G Gamma M A Delta Delta',
  G & Delta |= Gamma |- M ::: A ->
  ok_Bg_LF (Gamma :: G & (Delta ++ Delta')) ->
  G & (Delta++Delta')|= Gamma |- M ::: A.
intros; eapply WeakeningWithinContext_LF; eauto.
Qed.

Lemma types_weakened_LF:
forall G G' Gamma M A
  (Ok: ok_Bg_LF (Gamma::G ++ G'))
  (HT: emptyEquiv_LF G ++ G' |= nil |- M ::: A),
  G ++ G'|= Gamma |- M ::: A.
induction G; intros; simpl in *; rew_app in *; auto.
apply WeakeningGamma_LF with (Gamma':=Gamma) in HT; rew_app in *; auto.
assert (a :: G ++ G' ~=~ G ++ a::G') by PPermut_LF_simpl.
apply PPermutationG_LF with (G:=G ++ a:: G'); auto; apply IHG.
apply ok_Bg_LF_PPermut with (G:=Gamma :: a :: G ++ G'); auto.
assert (emptyEquiv_LF G ++ a :: G' ~=~
  (emptyEquiv_LF G ++ G') & (nil ++ a)).
  PPermut_LF_simpl.
apply PPermutationG_LF with (G:=(emptyEquiv_LF G  ++ G') & (nil ++ a)); auto.
eapply WeakeningWithinG.
rew_app.
apply ok_Bg_LF_empty_first in Ok.
assert (nil :: a :: G ++ G' ~=~ (nil :: G) ++ a :: G') by
  PPermut_LF_simpl.
apply ok_Bg_LF_PPermut with (G':=(nil::G)++ a::G') in Ok; auto.
eapply emptyEquiv_LF_ok_Bg_part in Ok; simpl in *; rew_app in *; auto.
assert (emptyEquiv_LF G & nil ++ G' ~=~  nil :: emptyEquiv_LF G ++ G') by
  PPermut_LF_simpl.
apply PPermutationG_LF with (G:= nil::emptyEquiv_LF G ++ G'); auto.
PPermut_LF_simpl.
apply ok_Bg_LF_nil. rew_app. apply emptyEquiv_LF_ok_Bg_part.
apply ok_Bg_LF_PPermut with (a::G ++ G');
try PPermut_LF_simpl.
eapply ok_Bg_LF_weakening; eauto.
Qed.

Lemma subst_t_LF_preserv_types:
forall G Gamma B M N v A
  (H_lc_t: lc_t_LF M)
  (HT: G |= Gamma |- N ::: B),
  (* "inner" substitution *)
  ( forall Gamma0,
    Gamma *=* ((v, A) :: Gamma0) ->
    emptyEquiv_LF G |= nil |- M ::: A ->
    G |= Gamma0 |- [M // fte v] N ::: B)
  /\
  (* "outer" substitution *)
  ( forall G0 G' G'' Gamma',
    G ~=~ (G0 & ((v,A)::Gamma')) ->
    G' ~=~ (G0 & Gamma) ->
    G'' ~=~ (G0 & Gamma') ->
    emptyEquiv_LF G' |= nil |- M ::: A ->
    G'' |= Gamma |- [M // fte v] N ::: B).
intros.
generalize dependent v;
generalize dependent A;
generalize dependent M.
induction HT; split; intros;
simpl in *.

(* hyp *)
case_if.
inversion H2; subst.
assert (A = A0) by (eapply ok_Bg_LF_Mem_eq; eauto);
subst; replace G with (G ++ nil) by (rew_app; auto).
apply types_weakened_LF.
apply ok_Bg_LF_permut_first_tail with (C':=Gamma0)(x:=v)(A:=A0) in Ok;
auto; rew_app; auto. rew_app; auto.

constructor.
apply ok_Bg_LF_permut_first_tail with (C':=Gamma0) (x:=v0) (A:=A0) in Ok; eauto.
apply Mem_permut with (l' := (v0, A0) :: Gamma0) in H; eauto;
rewrite Mem_cons_eq in H; destruct H; auto.
inversion H; subst; elim H2; reflexivity.

case_if.
inversion H4; subst.
apply ok_Bg_LF_Mem_contradict with (v:=v) (A:=A) (A':=A0) (G':=G0) (C':=Gamma')
  in Ok; rew_app in *;
contradiction || eauto.
constructor; auto.
apply ok_Bg_LF_PPermut with (G:=(Gamma::G0) & Gamma').
apply ok_Bg_LF_PPermut with (G':=(Gamma::G0 & ((v0, A0)::Gamma'))) in Ok.
apply ok_Bg_LF_permut_no_last with (v:=v0)(A:=A0); auto.
rewrite H0; PPermut_LF_simpl.
rewrite H2; PPermut_LF_simpl.

(* lam *)
apply t_lam_LF with (L:=L \u \{v}).
apply ok_Bg_LF_permut_first_tail with (C:=Gamma) (x:=v) (A:=A0); auto.
intros.
rewrite notin_union in H3; rewrite notin_singleton in H3; destruct H3.
unfold open_LF in *;
rewrite <- subst_t_comm_LF; auto.
eapply H0; auto;
permut_simpl || rew_app; eauto.

apply t_lam_LF with (L:=L \u \{v}).
apply ok_Bg_LF_PPermut with (G':=Gamma::G0 & ((v,A0)::Gamma')) in Ok.
apply ok_Bg_LF_PPermut with (G:=(Gamma::G0) & Gamma').
apply ok_Bg_LF_permut_no_last with (v:=v) (A:=A0); rew_app; auto.
rewrite H3; auto. rewrite H1; auto.
intros.
rewrite notin_union in H5; rewrite notin_singleton in H5; destruct H5;
unfold open_LF in *;
rewrite <- subst_t_comm_LF; auto.
eapply H0 with (G0:=G0); eauto;
assert (emptyEquiv_LF G' ~=~
  emptyEquiv_LF (G0 ++ nil & ((v0, A) :: Gamma))).

 (rewrite H2; rew_app; eapply emptyEquiv_LF_last_change; auto).
rew_app in *.
apply PPermutationG_LF with (G:=emptyEquiv_LF G'); auto.

(* appl *)
econstructor;  [ | eapply IHHT1 | eapply IHHT2]; eauto.
apply ok_Bg_LF_permut_first_tail with (C':=Gamma0) (x:=v) (A:=A0) in Ok; eauto.

econstructor.
apply ok_Bg_LF_PPermut with (G:=Gamma:: G0 & Gamma'); auto.
apply ok_Bg_LF_PPermut with (G':=Gamma :: G0 & ((v,A0)::Gamma')) in Ok; auto.

apply ok_Bg_LF_permut_no_last_spec in Ok; rew_app; auto.
eapply IHHT1; eauto.
eapply IHHT2; eauto.

(* box *)
constructor.
apply ok_Bg_LF_permut_no_last with (v:=v) (A:=A0);
apply ok_Bg_LF_PPermut with (G:=G & Gamma); auto.
eapply IHHT; eauto.
rewrite emptyEquiv_LF_rewrite; rewrite emptyEquiv_LF_rewrite_last;
simpl; rew_app. apply PPermutationG_LF with (nil :: emptyEquiv_LF G).
apply WeakeningG_LF; auto.

repeat apply ok_Bg_LF_nil. apply ok_Bg_LF_emptyEquiv.
PPermut_LF_simpl.

constructor.

apply ok_Bg_LF_PPermut with (G:=G0 & Gamma & Gamma').
apply ok_Bg_LF_permut_no_last with (v:=v) (A:=A0).
apply ok_Bg_LF_PPermut with (G:=G & Gamma); auto.
rewrite H; PPermut_LF_simpl.
rewrite H1; PPermut_LF_simpl.
eapply IHHT with (G0:=G0 & Gamma) (Gamma':=Gamma'); auto.
rewrite H; PPermut_LF_simpl; eauto.
rewrite H1; PPermut_LF_simpl.
repeat rewrite emptyEquiv_LF_rewrite;
simpl; rew_app.
apply PPermutationG_LF with (G:=nil::emptyEquiv_LF G').
apply WeakeningG_LF; auto.
repeat apply ok_Bg_LF_nil; apply ok_Bg_LF_emptyEquiv.
rewrite H0; rewrite emptyEquiv_LF_rewrite_last; simpl;
PPermut_LF_simpl.

(* unbox *)
econstructor; [ | eapply IHHT]; eauto;
apply ok_Bg_LF_permut_first_tail with (C':=Gamma0) (x:=v) (A:=A0) in Ok; eauto.

econstructor.
apply ok_Bg_LF_PPermut with (G:=G0 & Gamma & Gamma').
apply ok_Bg_LF_permut_no_last with (v:=v) (A:=A0).
apply ok_Bg_LF_PPermut with (G:=Gamma :: G); auto.
rewrite H; PPermut_LF_simpl.
rewrite H1; PPermut_LF_simpl.
eapply IHHT; eauto.

(* unbox_fetch *)
apply t_unbox_fetch_LF with (G:=G) (Gamma:=Gamma); auto;
[ apply ok_Bg_LF_permut_no_last_spec with (v:=v) (A:=A0);
  apply ok_Bg_LF_PPermut with (G:= Gamma :: G & Gamma') |
  eapply IHHT; eauto]; auto.
rewrite emptyEquiv_LF_rewrite; simpl.
apply PPermutationG_LF with (emptyEquiv_LF G'); auto.
rewrite <- H; rewrite emptyEquiv_LF_rewrite; simpl; auto.

destruct (permut_dec (var * ty) Gamma ((v,A0)::Gamma'0)).
  intros; destruct k; destruct k'; repeat decide equality.
  apply eq_var_dec.
(* = *)
assert (G ~=~ G0).
  apply PPermut_LF_last_rev with (Gamma:=Gamma)(Gamma':=(v,A0)::Gamma'0);
  auto.
  transitivity G'; auto.
apply t_unbox_fetch_LF with (G:=G) (Gamma:=Gamma'0).
apply ok_Bg_LF_PPermut with (Gamma' :: G & Gamma'0).
apply ok_Bg_LF_permut_no_last_spec with (v:=v)(A:=A0).
apply ok_Bg_LF_PPermut with (Gamma :: G & Gamma').
auto. transitivity (((v,A0)::Gamma'0):: G & Gamma'); auto.
PPermut_LF_simpl. rew_app. transitivity (Gamma' :: Gamma'0 :: G);
PPermut_LF_simpl; auto. transitivity (Gamma'0 :: Gamma' :: G);
rew_app; PPermut_LF_simpl; auto. rew_app. constructor; auto.
PPermut_LF_simpl.
destruct IHHT with (M0:=M0) (A0:=A0) (v:=v); auto.
apply H5; auto. apply PPermutationG_LF with (G:=emptyEquiv_LF G'0);
auto. rewrite H1; rewrite H4; auto.
symmetry; rewrite H4; auto.
(* <> *)
assert (exists Gamma'', exists GH, exists GT,
  Gamma'' *=* (v, A0)::Gamma'0 /\ G = GH & Gamma'' ++ GT) as HP.
  apply PPermut_LF_split_neq with (Gamma:=Gamma) (G':=G0);
    auto; transitivity G'; auto.
destruct HP as (Gamma'', (GH, (GT, (HPa, HPb)))).
assert (GH & Gamma'' ++ GT ~=~ GH & ((v, A0)::Gamma'0) ++ GT)
  by PPermut_LF_simpl;
apply t_unbox_fetch_LF with (G:=GH ++ GT & (Gamma'0)) (Gamma:=Gamma).
subst;
apply ok_Bg_LF_PPermut with
  (G:= (((Gamma) :: (GH & (Gamma') ++ GT)) & (Gamma'0))).
apply ok_Bg_LF_permut_no_last_spec with (v:=v)(A:=A0).
apply ok_Bg_LF_PPermut with
  (G:=(Gamma):: (GH & (Gamma'') ++ GT) & (Gamma')); auto.
constructor; auto. PPermut_LF_simpl.
PPermut_LF_simpl.
destruct IHHT with (M0:=M0) (A0:=A0) (v:= v); auto.
eapply H6 with (Gamma'0:=Gamma'0) (G0:=GH ++ GT & Gamma')
  (G':=GH ++ GT & Gamma' & Gamma);subst; try PPermut_LF_simpl.
clear H5 H6 IHHT.
assert (GH ++ Gamma'' :: GT & Gamma ~=~ G0 & Gamma'').
  transitivity G'; rew_app in *; auto; rewrite H0; auto.
assert (GH ++ GT & Gamma ~=~ G0).
  apply PPermut_LF_last_rev_simpl with (a:=Gamma'');
    rewrite <- H5; PPermut_LF_simpl.
apply PPermutationG_LF with (G := emptyEquiv_LF G'0); auto.
rewrite H1; rewrite <- H6; repeat rewrite emptyEquiv_LF_rewrite;
PPermut_LF_simpl.
rewrite H2.
rew_app; PPermut_LF_simpl; apply PPermut_LF_last_rev_simpl
  with (a:=(v,A0)::Gamma'0). rewrite <- H0; rewrite <- H; subst;
  PPermut_LF_simpl.

(* here *)
econstructor; [ | eapply IHHT]; eauto;
apply ok_Bg_LF_permut_first_tail with (C':=Gamma0) (x:=v) (A:=A0) in Ok; eauto.

econstructor.
apply ok_Bg_LF_PPermut with (G:=G0 & Gamma & Gamma').
apply ok_Bg_LF_permut_no_last with (v:=v) (A:=A0).
apply ok_Bg_LF_PPermut with (G:=Gamma :: G); auto.
rewrite H; PPermut_LF_simpl.
rewrite H1; PPermut_LF_simpl.
eapply IHHT; eauto.

(* get_here *)
apply t_get_here_LF with (G:=G) (Gamma:=Gamma); auto;
[ apply ok_Bg_LF_permut_no_last_spec with (v:=v) (A:=A0);
  apply ok_Bg_LF_PPermut with (G:= Gamma :: G & Gamma') |
  eapply IHHT; eauto]; auto.
rewrite emptyEquiv_LF_rewrite; simpl.
apply PPermutationG_LF with (emptyEquiv_LF G'); auto.
rewrite <- H; rewrite emptyEquiv_LF_rewrite; simpl; auto.

destruct (permut_dec (var * ty) Gamma ((v,A0)::Gamma'0)).
  intros; destruct k; destruct k'; repeat decide equality.
  apply eq_var_dec.
(* = *)
assert (G ~=~ G0).
  apply PPermut_LF_last_rev with (Gamma:=Gamma)(Gamma':=(v,A0)::Gamma'0);
  auto.
  transitivity G'; auto.
apply t_get_here_LF with (G:=G) (Gamma:=Gamma'0).
apply ok_Bg_LF_PPermut with (Gamma' :: G & Gamma'0).
apply ok_Bg_LF_permut_no_last_spec with (v:=v)(A:=A0).
apply ok_Bg_LF_PPermut with (Gamma :: G & Gamma').
auto. transitivity (((v,A0)::Gamma'0):: G & Gamma'); auto.
PPermut_LF_simpl. rew_app. transitivity (Gamma' :: Gamma'0 :: G);
PPermut_LF_simpl; auto. transitivity (Gamma'0 :: Gamma' :: G);
rew_app; PPermut_LF_simpl; auto. rew_app. constructor; auto.
PPermut_LF_simpl.
destruct IHHT with (M0:=M0) (A0:=A0) (v:=v); auto.
apply H5; auto. apply PPermutationG_LF with (G:=emptyEquiv_LF G'0);
auto. rewrite H1; rewrite H4; auto.
symmetry; rewrite H4; auto.
(* <> *)
assert (exists Gamma'', exists GH, exists GT,
  Gamma'' *=* (v, A0)::Gamma'0 /\ G = GH & Gamma'' ++ GT) as HP.
  apply PPermut_LF_split_neq with (Gamma:=Gamma) (G':=G0);
    auto; transitivity G'; auto.
destruct HP as (Gamma'', (GH, (GT, (HPa, HPb)))).
assert (GH & Gamma'' ++ GT ~=~ GH & ((v, A0)::Gamma'0) ++ GT)
  by PPermut_LF_simpl;
apply t_get_here_LF with (G:=GH ++ GT & (Gamma'0)) (Gamma:=Gamma).
subst;
apply ok_Bg_LF_PPermut with
  (G:= (((Gamma) :: (GH & (Gamma') ++ GT)) & (Gamma'0))).
apply ok_Bg_LF_permut_no_last_spec with (v:=v)(A:=A0).
apply ok_Bg_LF_PPermut with
  (G:=(Gamma):: (GH & (Gamma'') ++ GT) & (Gamma')); auto.
constructor; auto. PPermut_LF_simpl.
PPermut_LF_simpl.
destruct IHHT with (M0:=M0) (A0:=A0) (v:= v); auto.
eapply H6 with (Gamma'0:=Gamma'0) (G0:=GH ++ GT & Gamma')
  (G':=GH ++ GT & Gamma' & Gamma);subst; try PPermut_LF_simpl.
clear H5 H6 IHHT.
assert (GH ++ Gamma'' :: GT & Gamma ~=~ G0 & Gamma'').
  transitivity G'; rew_app in *; auto; rewrite H0; auto.
assert (GH ++ GT & Gamma ~=~ G0).
  apply PPermut_LF_last_rev_simpl with (a:=Gamma'');
    rewrite <- H5; PPermut_LF_simpl.
apply PPermutationG_LF with (G := emptyEquiv_LF G'0); auto.
rewrite H1; rewrite <- H6; repeat rewrite emptyEquiv_LF_rewrite;
PPermut_LF_simpl.
rewrite H2.
rew_app; PPermut_LF_simpl; apply PPermut_LF_last_rev_simpl
  with (a:=(v,A0)::Gamma'0). rewrite <- H0; rewrite <- H; subst;
  PPermut_LF_simpl.

(* letdia *)
apply t_letdia_LF with (L := L \u \{v}) (A:=A);
[ apply ok_Bg_LF_permut_first_tail with (C:=Gamma) (x:=v) (A:=A0) |
  eapply IHHT |
  intros]; eauto;
unfold open_LF in *.
rewrite notin_union in H2; rewrite notin_singleton in H2; destruct H2.
rewrite <- subst_t_comm_LF. eapply H; eauto.
apply PPermutationG_LF with (G:=emptyEquiv_LF(((v0,A)::nil)::G)).
simpl. apply WeakeningG_LF. auto.
repeat apply ok_Bg_LF_nil; apply ok_Bg_LF_empty.
rewrite H3; auto.
auto. auto.

eapply t_letdia_LF with
  (L := L \u \{v}).
apply ok_Bg_LF_PPermut with (G:= (Gamma :: G0) & Gamma').
apply ok_Bg_LF_permut_no_last with (v:=v) (A:=A0).
rew_app. apply ok_Bg_LF_PPermut with (G:=Gamma :: G); auto.
rewrite H2; rew_app; auto.
eapply IHHT with (A0:=A0) ; eauto.
intros; unfold open_LF in *.
rewrite notin_union in H4; rewrite notin_singleton in H4; destruct H4;
rewrite <- subst_t_comm_LF; auto.
destruct H with (v:=v0) (M:=M0) (A:=A0) (v0:=v) (G':=((v0,A)::nil)::G); auto.
apply PPermutationG_LF with (G:=((v0,A)::nil)::G0 & Gamma').
eapply H8 with (G0:=G0 & ((v0, A)::nil)) (Gamma':=Gamma').
rewrite H0; PPermut_LF_simpl. eauto. PPermut_LF_simpl.
apply PPermutationG_LF with (G:=emptyEquiv_LF(((v0,A)::nil) ::G')).
simpl; apply WeakeningG_LF; auto.
repeat apply ok_Bg_LF_nil; apply ok_Bg_LF_empty.
rewrite H1; repeat rewrite emptyEquiv_LF_rewrite; simpl; PPermut_LF_simpl.
repeat rewrite emptyEquiv_LF_rewrite; simpl; auto.
rewrite <- H5. rewrite H2. auto.

(* letdia_get *)
eapply t_letdia_get_LF with (G:=G) (Gamma:=Gamma) (L := L \u \{v}) (A:=A);
auto.
apply ok_Bg_LF_permut_no_last_spec with (v:=v) (A:=A0);
apply ok_Bg_LF_PPermut with (G:= (Gamma) :: G & Gamma'); auto.
eapply IHHT with (Gamma'0:=Gamma0) (v:=v) (A0:=A0); auto.
apply PPermutationG_LF with (G:= emptyEquiv_LF(G0)); auto.
rewrite H0; auto.
intros; unfold open_LF in *.
rewrite notin_union in H3; rewrite notin_singleton in H3; destruct H3;
rewrite <- subst_t_comm_LF; auto.
destruct H with (v:=v0) (M:=M0)(A0:=A0)(v0:=v); auto.
eapply H5; eauto.
apply PPermutationG_LF with (G:= emptyEquiv_LF(nil::G0)); simpl; auto.
apply WeakeningG_LF; auto.
repeat apply ok_Bg_LF_nil; apply ok_Bg_LF_empty.
rewrite H0; auto.

destruct (permut_dec (var * ty) Gamma ((v,A0)::Gamma'0)).
  intros; destruct k; destruct k'; repeat decide equality.
  apply eq_var_dec.
(* = *)
assert (G ~=~ G1).
  apply PPermut_LF_last_rev with (Gamma:=Gamma)(Gamma':=(v,A0)::Gamma'0);
  auto.
  transitivity G0; auto.
apply t_letdia_get_LF with (G:=G1) (Gamma:=Gamma'0)
  (L:=L \u \{v}) (A:=A); eauto.
apply ok_Bg_LF_PPermut with (G:=Gamma'::G & Gamma'0); auto.
apply ok_Bg_LF_permut_no_last_spec with (v:=v)(A:=A0).
apply ok_Bg_LF_PPermut with (Gamma :: G & Gamma'); auto.
transitivity (Gamma :: Gamma' :: G).
PPermut_LF_simpl.
transitivity (Gamma' :: Gamma :: G).
PPermut_LF_simpl. constructor; auto. PPermut_LF_simpl.
rewrite H5. transitivity (Gamma' :: Gamma'0::G1).
constructor; auto; PPermut_LF_simpl.
transitivity (Gamma'0::Gamma'::G1); auto.
constructor; auto; PPermut_LF_simpl.
destruct IHHT with (M0:=M0) (v:=v) (A0:=A0); auto.
apply PPermutationG_LF with (G:=G & Gamma'); auto.
apply H6; auto.
apply PPermutationG_LF with (G:=emptyEquiv_LF G'); auto.
rewrite H5; rewrite H2; auto.
intros; unfold open_LF in *.
rewrite notin_union in H6; rewrite notin_singleton in H6; destruct H6;
rewrite <- subst_t_comm_LF; auto.
edestruct H with (v:=v0) (A0:=A0)
  (v0:=v) (M:=M0) as (Ha, Hb);
auto.
eapply Hb with (G0 := ((v0,A)::nil) ::G) (Gamma'0:=Gamma'0);
[ | auto |  | ]; try PPermut_LF_simpl.
rew_app; simpl. apply WeakeningG_LF.
apply PPermutationG_LF with (G:=emptyEquiv_LF G');
auto. rewrite H2; rewrite H5; auto.
repeat apply ok_Bg_LF_nil; apply ok_Bg_LF_empty.

(* <> *)
assert (G & (Gamma) ~=~ G1 & ((v, A0) :: Gamma'0)).
  (transitivity G0; auto).
symmetry in H5;
assert (exists Gamma0, exists GH, exists GT,
  Gamma0 *=* Gamma /\ G1 = GH & (Gamma0) ++ GT).
  (apply PPermut_LF_split_neq with (Gamma:=(v,A0) :: Gamma'0) (G':=G);
    auto).
  intro; elim n; symmetry; auto.
destruct H6 as (Gamma'', (GH, (GT, (H8, H9)))).
apply t_letdia_get_LF with (G:=GH++GT & (Gamma'0)) (Gamma:=Gamma) (A:=A)
  (L:=L \u \{v}); auto.
apply ok_Bg_LF_PPermut with (G:=Gamma' :: (G1 & Gamma'0)).
apply ok_Bg_LF_permut_no_last_spec with (v:=v)(A:=A0).
apply ok_Bg_LF_PPermut with (G:=Gamma :: G & Gamma'); auto.
transitivity ((G & Gamma) & Gamma'). auto.
rewrite <- H5. transitivity (G1 & Gamma' & ((v,A0)::Gamma'0)).
PPermut_LF_simpl. auto.
subst; PPermut_LF_simpl.
destruct IHHT with (M0:=M0) (A0:=A0) (v:=v); auto.
eapply H7 with (G0:=GH ++ GT & Gamma') (Gamma'0:=Gamma'0).
rew_app; PPermut_LF_simpl; subst.
apply PPermut_LF_last_rev with (Gamma:=Gamma) (Gamma':=Gamma'');
[ symmetry | ]; auto. rewrite <- H5.
PPermut_LF_simpl. eauto.
PPermut_LF_simpl.
apply PPermutationG_LF with (G:= emptyEquiv_LF(G')).
auto.
subst; rewrite H2; repeat rewrite emptyEquiv_LF_rewrite; simpl;
PPermut_LF_simpl.
intros; unfold open_LF in *.
rewrite notin_union in H6; rewrite notin_singleton in H6; destruct H6;
rewrite <- subst_t_comm_LF; auto.
destruct H with (v:=v0) (M:=M0) (A0:=A0) (v0:=v); auto.
eapply H11 with (G0:= G1 & ((v0,A)::nil)) (Gamma'0:=Gamma'0).
subst; rewrite <- H5; rew_app; PPermut_LF_simpl.
eauto.
subst; rew_app; PPermut_LF_simpl.
apply PPermutationG_LF with (G:=emptyEquiv_LF (((v0,A)::nil) :: G')).
simpl; apply WeakeningG_LF; auto.
repeat apply ok_Bg_LF_nil; apply ok_Bg_LF_empty.
subst; rewrite H2. apply Permut_emptyEquiv.
PPermut_LF_simpl.
rewrite H3; subst; PPermut_LF_simpl.
Qed.

Lemma subst_t_LF_preserv_types_inner:
forall G Gamma A B M N v
  (H_lc_t: lc_t_LF M)
  (HT: G |= (v, A) :: Gamma |- N ::: B)
  (HM: emptyEquiv_LF G |= nil |- M ::: A),
  G |= Gamma |- [M//fte v] N ::: B.
intros; eapply subst_t_LF_preserv_types with (Gamma := (v, A) :: Gamma); eauto.
Qed.

Lemma subst_t_LF_preserv_types_outer:
forall G0 G G' G'' Gamma Gamma' A B M N v
  (H_lc_t: lc_t_LF M)
  (G0G: G ~=~ (G0 & ((v, A) :: Gamma')))
  (G0G': G' ~=~ (G0 & Gamma))
  (G0G'': G'' ~=~ (G0 & Gamma'))
  (HM: emptyEquiv_LF G' |= nil |- M ::: A)
  (HT: G |= Gamma |- N ::: B),
  G'' |= Gamma |- [M // fte v] N ::: B.
intros; eapply subst_t_LF_preserv_types; eauto.
Qed.

Lemma merge_LF_preserv_types:
forall G Gamma M A
  (H: G |= Gamma |- M ::: A),
  (* outer *)
  (forall G0 G1 Gamma0 Delta0,
    G ~=~ Gamma0::Delta0::G0 ->
    G1 ~=~ (Gamma0++Delta0) :: G0 ->
    G1 |= Gamma |- M ::: A) /\
  (* new or old - by PermutationGamma_LF *)
  (forall G0 Delta0,
    G ~=~ Delta0 :: G0 ->
    G0 |= Gamma ++ Delta0 |- M ::: A).
intros; induction H; repeat split; intros.
(* hyp *)
constructor; auto.
eapply ok_Bg_LF_concat with (G0:=Gamma::G0) (c1:=Gamma0) (c2:=Delta0)
  (G1:=Gamma::G) (G2:=Gamma::G1);
eauto; [rewrite H0 | rewrite H1]; PPermut_LF_simpl.
constructor.
eapply ok_Bg_LF_concat with (G0:=G0) (G1:=Gamma::G); eauto.
rewrite Mem_app_or_eq; left; auto.
(* lam *)
apply t_lam_LF with (L:=L).
eapply ok_Bg_LF_concat with (G0:=Gamma::G0) (G1:=Gamma::G); eauto;
try rewrite H2 || rewrite H1; auto; PPermut_LF_simpl.
intros; eapply H0; eauto.
apply t_lam_LF with (L:=L).
eapply ok_Bg_LF_concat with (G0:=G0) (G1:=Gamma::G); eauto.
intros; eapply H0; eauto.
(* appl *)
apply t_appl_LF with (A:=A).
eapply ok_Bg_LF_concat with (G0:=Gamma::G0) (G1:=Gamma::G) (c1:=Gamma0)
  (c2:=Delta0); eauto;
try rewrite H2 || rewrite H1; eauto; PPermut_LF_simpl.
eapply IHtypes_LF1; eauto.
eapply IHtypes_LF2; eauto.
apply t_appl_LF with (A:=A).
eapply ok_Bg_LF_concat with (G0:=G0) (G1:=Gamma::G); eauto.
eapply IHtypes_LF1; eauto.
eapply IHtypes_LF2; eauto.
(* box *)
constructor.
eapply ok_Bg_LF_concat with (G0:=G0 & Gamma) (G1:=G & Gamma)
  (c1:=Gamma0) (c2:=Delta0); eauto;
try rewrite H0 || rewrite H1; auto.
eapply IHtypes_LF with (G0:=G0 & Gamma) (Gamma0:=Gamma0) (Delta0:=Delta0);
eauto.
rewrite H0; PPermut_LF_simpl.
rewrite H1; PPermut_LF_simpl.
constructor.
eapply ok_Bg_LF_concat with (G0:=G0) (G1:=G & Gamma)
  (c1:=Gamma) (c2:=Delta0); eauto; try PPermut_LF_simpl.
eapply IHtypes_LF with (G0:=G0) (Gamma0:=Gamma)
  (Delta0:=Delta0); eauto. rewrite H0; PPermut_LF_simpl. PPermut_LF_simpl.
(* unbox *)
constructor.
eapply ok_Bg_LF_concat with (G0:=Gamma::G0) (G1:=Gamma::G)
  (c1:=Gamma0)(c2:=Delta0); eauto;
try rewrite H0 || rewrite H1; PPermut_LF_simpl.
eapply IHtypes_LF; eauto.
constructor.
eapply ok_Bg_LF_concat with (G0:=G0) (G1:=Gamma::G); eauto.
eapply IHtypes_LF; eauto.
(* Gamma *=* Gamma0 \/ Gamma *=* Gamma1 \/ neither *)
assert (G & Gamma ~=~ Gamma0 :: Delta0 :: G0).
  transitivity G'; auto.
assert ((Gamma *=* Gamma0 /\ G ~=~ Delta0::G0) \/
        (Gamma *=* Delta0 /\ G ~=~ Gamma0::G0) \/
        (exists c, exists hd, exists tl, Gamma *=* c /\ G0 = hd & c ++ tl)).
  assert ({Gamma *=* Gamma0} + {~ Gamma *=* Gamma0}).
  apply permut_dec. intros. destruct k; destruct k'; decide equality.
  apply eq_ty_dec. apply eq_var_dec.
  assert ({Gamma *=* Delta0} + {~ Gamma *=* Delta0}).
  apply permut_dec. intros. destruct k; destruct k'; decide equality.
  apply eq_ty_dec. apply eq_var_dec.
  destruct H4. left; split; auto. apply PPermut_LF_last_rev with (Gamma:=Gamma)
  (Gamma':=Gamma0); auto; rewrite H3; PPermut_LF_simpl.
  destruct H5.
  right; left; split; auto. apply PPermut_LF_last_rev with (Gamma:=Gamma)
  (Gamma':=Delta0); auto; rewrite H3; PPermut_LF_simpl.
  right; right.
  assert (G & Gamma ~=~ G0 & Delta0 & Gamma0) by (rewrite H3; PPermut_LF_simpl).
  symmetry in H4.
  apply PPermut_LF_split_neq in H4; auto.
  destruct H4 as (Gamma'', (hd, (tl, (H4, H5)))).
  assert (G0 & Delta0 ~=~ (hd ++ tl) & Gamma).
    rewrite H5; PPermut_LF_simpl.
  apply PPermut_LF_split_neq in H6; auto.
  destruct H6 as (Delta'', (hd', (tl', (H6, H7)))).
  exists Delta''; exists hd'; exists tl'; split; auto; symmetry; auto.
  intro nn; symmetry in nn; elim n0; auto.
  intro nn; symmetry in nn; elim n; auto.
destruct H4. destruct H4.
apply t_unbox_fetch_LF with (G:=G0) (Gamma:=Gamma0++Delta0).
eapply ok_Bg_LF_concat
 with (G0:=G0 & Gamma') (G1:=Gamma::G & Gamma'); eauto;
rewrite H5; auto.
apply PermutationGamma_LF with (Gamma:=Gamma++Delta0); auto.
eapply IHtypes_LF. rewrite H5; auto. rewrite H2; PPermut_LF_simpl.
destruct H4.
destruct H4.
apply t_unbox_fetch_LF with (G:=G0) (Gamma:=Delta0++Gamma0).
eapply ok_Bg_LF_concat
 with (G0:=G0 & Gamma') (G1:=Gamma::G & Gamma'); eauto;
rewrite H5; auto.
apply PermutationGamma_LF with (Gamma:=Gamma++Gamma0); auto.
eapply IHtypes_LF. rewrite H5; auto. rewrite H2; PPermut_LF_simpl.
destruct H4 as (c, (hd, (tl, (H4a, H4)))).
apply t_unbox_fetch_LF with (G:=(Gamma0++Delta0)::hd++tl) (Gamma:=c).
eapply ok_Bg_LF_concat with (G0:=G0 & Gamma') (G1:=Gamma::G & Gamma')
  (c1:=Gamma0) (c2:=Delta0); subst; auto.
transitivity (G & Gamma & Gamma'); auto; rewrite H3; subst; eauto;
PPermut_LF_simpl.
transitivity ((Gamma0++Delta0)::c::hd++tl & Gamma'); [PPermut_LF_simpl |].
rew_app; auto.
apply PermutationGamma_LF with (Gamma:=Gamma); auto.
assert (G ~=~ Gamma0::Delta0::hd ++ tl).
  subst; apply PPermut_LF_last_rev with (Gamma:=Gamma) (Gamma':=c); auto;
  rewrite H3; PPermut_LF_simpl.
eapply IHtypes_LF with (Gamma0:=Gamma0) (Delta0:=Delta0) (G0:=hd ++tl & Gamma');
eauto.
rewrite H5. rew_app; auto. rew_app; auto. rewrite H2; subst; PPermut_LF_simpl.
assert (G & Gamma ~=~ Delta0 :: G0).
  transitivity G'; auto.
assert ((Gamma *=* Delta0 /\ G ~=~ G0) \/
        (exists c, exists hd, exists tl, c *=* Gamma /\ G0 = hd & c ++ tl)).
  assert ({Gamma *=* Delta0} + {~ Gamma *=* Delta0}).
  apply permut_dec. intros. destruct k; destruct k'; decide equality.
  apply eq_ty_dec. apply eq_var_dec.
  destruct H3. left; split; auto. apply PPermut_LF_last_rev with (Gamma:=Gamma)
  (Gamma':=Delta0); auto; rewrite H2; PPermut_LF_simpl.
  right.
  assert (G & Gamma ~=~ G0 & Delta0) by (rewrite H2; PPermut_LF_simpl).
  symmetry in H3.
  apply PPermut_LF_split_neq in H3; auto.
  intro nn; symmetry in nn; elim n; auto.
destruct H3.
destruct H3.
constructor.
eapply ok_Bg_LF_concat with (G0:=G0) (G1:=Gamma::G & Gamma'); eauto;
rewrite H4; PPermut_LF_simpl.
apply PermutationGamma_LF with (Gamma:=Gamma++Gamma').
eapply IHtypes_LF. rewrite H4; PPermut_LF_simpl.
permut_simpl; auto.
destruct H3 as (c, (hd, (tl, (H3a, H3)))); subst.
apply t_unbox_fetch_LF with (G:=hd++tl) (Gamma:=Gamma).
eapply ok_Bg_LF_concat with (G0:=Gamma::(hd++tl)) (G1:=Gamma::G & Gamma')
  (c1:=Gamma')(c2:=Delta0);
eauto.
transitivity (G & Gamma & Gamma'); auto; rewrite H2; PPermut_LF_simpl.
PPermut_LF_simpl.
assert (G ~=~ Delta0::hd ++ tl).
  apply PPermut_LF_last_rev with (Gamma:=Gamma) (Gamma':=c). symmetry; auto.
  rewrite H2; PPermut_LF_simpl.
eapply IHtypes_LF with (Gamma0:=Gamma') (Delta0 :=Delta0) (G0:= hd ++ tl).
rewrite H3; PPermut_LF_simpl. PPermut_LF_simpl. PPermut_LF_simpl.
(* here *)
constructor.
eapply ok_Bg_LF_concat with (G0:=Gamma::G0) (G1:=Gamma::G)
  (c1:=Gamma0)(c2:=Delta0); eauto;
try rewrite H0 || rewrite H1; PPermut_LF_simpl.
eapply IHtypes_LF; eauto.
constructor.
eapply ok_Bg_LF_concat with (G0:=G0) (G1:=Gamma::G); eauto.
eapply IHtypes_LF; eauto.
(* Gamma *=* Gamma0 \/ Gamma *=* Gamma1 \/ neither *)
assert (G & Gamma ~=~ Gamma0 :: Delta0 :: G0).
  transitivity G'; auto.
assert ((Gamma *=* Gamma0 /\ G ~=~ Delta0::G0) \/
        (Gamma *=* Delta0 /\ G ~=~ Gamma0::G0) \/
        (exists c, exists hd, exists tl, Gamma *=* c /\ G0 = hd & c ++ tl)).
  assert ({Gamma *=* Gamma0} + {~ Gamma *=* Gamma0}).
  apply permut_dec. intros. destruct k; destruct k'; decide equality.
  apply eq_ty_dec. apply eq_var_dec.
  assert ({Gamma *=* Delta0} + {~ Gamma *=* Delta0}).
  apply permut_dec. intros. destruct k; destruct k'; decide equality.
  apply eq_ty_dec. apply eq_var_dec.
  destruct H4. left; split; auto. apply PPermut_LF_last_rev with (Gamma:=Gamma)
  (Gamma':=Gamma0); auto; rewrite H3; PPermut_LF_simpl.
  destruct H5.
  right; left; split; auto. apply PPermut_LF_last_rev with (Gamma:=Gamma)
  (Gamma':=Delta0); auto; rewrite H3; PPermut_LF_simpl.
  right; right.
  assert (G & Gamma ~=~ G0 & Delta0 & Gamma0) by (rewrite H3; PPermut_LF_simpl).
  symmetry in H4.
  apply PPermut_LF_split_neq in H4; auto.
  destruct H4 as (Gamma'', (hd, (tl, (H4, H5)))).
  assert (G0 & Delta0 ~=~ (hd ++ tl) & Gamma).
    rewrite H5; PPermut_LF_simpl.
  apply PPermut_LF_split_neq in H6; auto.
  destruct H6 as (Delta'', (hd', (tl', (H6, H7)))).
  exists Delta''; exists hd'; exists tl'; split; auto; symmetry; auto.
  intro nn; symmetry in nn; elim n0; auto.
  intro nn; symmetry in nn; elim n; auto.
destruct H4. destruct H4.
apply t_get_here_LF with (G:=G0) (Gamma:=Gamma0++Delta0).
eapply ok_Bg_LF_concat
 with (G0:=G0 & Gamma') (G1:=Gamma::G & Gamma'); eauto;
rewrite H5; auto.
apply PermutationGamma_LF with (Gamma:=Gamma++Delta0); auto.
eapply IHtypes_LF. rewrite H5; auto. rewrite H2; PPermut_LF_simpl.
destruct H4.
destruct H4.
apply t_get_here_LF with (G:=G0) (Gamma:=Delta0++Gamma0).
eapply ok_Bg_LF_concat with (G0:=G0 & Gamma') (G1:=Gamma::G & Gamma')
  (c1:=Gamma0) (c2:=Delta0); subst; auto.
transitivity (G & Gamma & Gamma'); auto; rewrite H3; subst; eauto;
PPermut_LF_simpl.
apply PermutationGamma_LF with (Gamma:=Gamma++Gamma0); auto.
eapply IHtypes_LF. rewrite H5; auto. rewrite H2; PPermut_LF_simpl.
destruct H4 as (c, (hd, (tl, (H4a, H4)))).
apply t_get_here_LF with (G:=(Gamma0++Delta0)::hd++tl) (Gamma:=c).
eapply ok_Bg_LF_concat with (G0:=G0 & Gamma') (G1:=Gamma::G & Gamma')
  (c1:=Gamma0) (c2:=Delta0); subst; auto.
transitivity (G & Gamma & Gamma'); auto; rewrite H3; subst; eauto;
PPermut_LF_simpl.
transitivity ((Gamma0++Delta0)::c::hd++tl & Gamma'); [PPermut_LF_simpl |].
rew_app; auto.
apply PermutationGamma_LF with (Gamma:=Gamma); auto.
assert (G ~=~ Gamma0::Delta0::hd ++ tl).
  subst; apply PPermut_LF_last_rev with (Gamma:=Gamma) (Gamma':=c); auto;
  rewrite H3; PPermut_LF_simpl.
eapply IHtypes_LF with (Gamma0:=Gamma0) (Delta0:=Delta0) (G0:=hd ++tl & Gamma');
eauto.
rewrite H5. rew_app; auto. rew_app; auto. rewrite H2; subst; PPermut_LF_simpl.
assert (G & Gamma ~=~ Delta0 :: G0).
  transitivity G'; auto.
assert ((Gamma *=* Delta0 /\ G ~=~ G0) \/
        (exists c, exists hd, exists tl, c *=* Gamma /\ G0 = hd & c ++ tl)).
  assert ({Gamma *=* Delta0} + {~ Gamma *=* Delta0}).
  apply permut_dec. intros. destruct k; destruct k'; decide equality.
  apply eq_ty_dec. apply eq_var_dec.
  destruct H3. left; split; auto. apply PPermut_LF_last_rev with (Gamma:=Gamma)
  (Gamma':=Delta0); auto; rewrite H2; PPermut_LF_simpl.
  right.
  assert (G & Gamma ~=~ G0 & Delta0) by (rewrite H2; PPermut_LF_simpl).
  symmetry in H3.
  apply PPermut_LF_split_neq in H3; auto.
  intro nn; symmetry in nn; elim n; auto.
destruct H3.
destruct H3.
constructor.
eapply ok_Bg_LF_concat with (G0:=G0) (G1:=Gamma::G & Gamma'); eauto;
rewrite H4; PPermut_LF_simpl.
apply PermutationGamma_LF with (Gamma:=Gamma++Gamma').
eapply IHtypes_LF. rewrite H4; PPermut_LF_simpl.
permut_simpl; auto.
destruct H3 as (c, (hd, (tl, (H3a, H3)))); subst.
apply t_get_here_LF with (G:=hd++tl) (Gamma:=Gamma).
eapply ok_Bg_LF_concat with (G0:=Gamma::(hd++tl)) (G1:=Gamma::G & Gamma')
  (c1:=Gamma')(c2:=Delta0);
eauto.
transitivity (G & Gamma & Gamma'); auto; rewrite H2; PPermut_LF_simpl.
PPermut_LF_simpl.
assert (G ~=~ Delta0::hd ++ tl).
  apply PPermut_LF_last_rev with (Gamma:=Gamma) (Gamma':=c). symmetry; auto.
  rewrite H2; PPermut_LF_simpl.
eapply IHtypes_LF with (Gamma0:=Gamma') (Delta0 :=Delta0) (G0:= hd ++ tl).
rewrite H3; PPermut_LF_simpl. PPermut_LF_simpl. PPermut_LF_simpl.
(* letdia *)
apply t_letdia_LF with (L:=L) (A:=A).
eapply ok_Bg_LF_concat with (G0:=Gamma::G0) (G1:=Gamma::G) (c1:=Gamma0)
  (c2:=Delta0);
eauto; rewrite H1 || rewrite H2; auto; PPermut_LF_simpl.
  eapply IHtypes_LF; eauto. intros.
  apply PPermutationG_LF with  (G:=((v, A) :: nil) :: G1).
  apply PPermutationG_LF with (G:= ((v,A)::nil)::(Gamma0 ++ Delta0) :: G0).
  eapply H0 with (G':=((v,A)::nil)::G) (G0:= ((v,A)::nil)::G0)
    (Delta0:=Delta0)(Gamma0:=Gamma0); eauto.
  PPermut_LF_simpl. PPermut_LF_simpl; auto. auto.
apply t_letdia_LF with (L:=L) (A:=A).
eapply ok_Bg_LF_concat with (G0:=G0) (G1:=Gamma::G) (c1:=Gamma)
  (c2:=Delta0);
eauto.
  eapply IHtypes_LF; eauto. intros.
  apply PPermutationG_LF with (G:=((v, A) :: nil) :: G0).
  eapply H0 with (G':=((v,A)::nil)::G); eauto.
  rewrite H1; PPermut_LF_simpl. auto.
assert (G & Gamma ~=~ Gamma0 :: Delta0 :: G1).
  transitivity G0; auto.
assert ((Gamma *=* Gamma0 /\ G ~=~ Delta0::G1) \/
        (Gamma *=* Delta0 /\ G ~=~ Gamma0::G1) \/
        (exists c, exists hd, exists tl, Gamma *=* c /\ G1 = hd & c ++ tl)).
  assert ({Gamma *=* Gamma0} + {~ Gamma *=* Gamma0}).
  apply permut_dec. intros. destruct k; destruct k'; decide equality.
  apply eq_ty_dec. apply eq_var_dec.
  assert ({Gamma *=* Delta0} + {~ Gamma *=* Delta0}).
  apply permut_dec. intros. destruct k; destruct k'; decide equality.
  apply eq_ty_dec. apply eq_var_dec.
  destruct H5. left; split; auto. apply PPermut_LF_last_rev with (Gamma:=Gamma)
  (Gamma':=Gamma0); auto; rewrite H4; PPermut_LF_simpl.
  destruct H6.
  right; left; split; auto. apply PPermut_LF_last_rev with (Gamma:=Gamma)
  (Gamma':=Delta0); auto; rewrite H4; PPermut_LF_simpl.
  right; right.
  assert (G & Gamma ~=~ G1 & Delta0 & Gamma0) by (rewrite H4; PPermut_LF_simpl).
  symmetry in H5.
  apply PPermut_LF_split_neq in H5; auto.
  destruct H5 as (Gamma'', (hd, (tl, (H5, H6)))).
  assert (G1 & Delta0 ~=~ (hd ++ tl) & Gamma).
    rewrite H6; PPermut_LF_simpl.
  apply PPermut_LF_split_neq in H7; auto.
  destruct H7 as (Delta'', (hd', (tl', (H7, H8)))).
  exists Delta''; exists hd'; exists tl'; split; auto; symmetry; auto.
  intro nn; symmetry in nn; elim n0; auto.
  intro nn; symmetry in nn; elim n; auto.
destruct H5. destruct H5.
apply t_letdia_get_LF with (G:=G1) (Gamma:=Gamma++Delta0) (L:=L) (A:=A).
eapply ok_Bg_LF_concat with (G0:=G1 & Gamma') (G1:=Gamma::G & Gamma'); eauto;
rewrite H6; auto.
eapply IHtypes_LF.
rewrite H6; PPermut_LF_simpl.
intros. eapply H0 with (G0:=((v,A)::nil)::G1) (Gamma0:=Gamma0)(Delta0:=Delta0);
eauto. rewrite H6; PPermut_LF_simpl. PPermut_LF_simpl.
rewrite H3; PPermut_LF_simpl.
destruct H5. destruct H5.
apply t_letdia_get_LF with (G:=G1) (Gamma:=Gamma++Gamma0) (A:=A) (L:=L).
eapply ok_Bg_LF_concat with (G0:=G1 & Gamma') (G1:=Gamma::G & Gamma'); eauto;
rewrite H6; auto.
eapply IHtypes_LF. rewrite H6; PPermut_LF_simpl.
intros.
eapply H0 with (G0:=((v,A)::nil)::G1) (Gamma0:=Gamma0)(Delta0:=Delta0);
eauto. rewrite H6; PPermut_LF_simpl. PPermut_LF_simpl; constructor. rewrite H5.
auto. auto. rewrite H3; PPermut_LF_simpl. constructor; auto; rewrite H5; auto.
destruct H5 as (c, (hd, (tl, (H5a, H5)))).
apply t_letdia_get_LF with
  (G:=(Gamma0++Delta0)::hd++tl)(Gamma:=Gamma) (L:=L)(A:=A).
eapply ok_Bg_LF_concat with (G0:=Gamma::(hd++tl)&Gamma') (G1:=Gamma::G & Gamma')
  (c1:=Gamma0)(c2:=Delta0);
eauto.
transitivity (G & Gamma & Gamma'); auto; rewrite H4; subst; PPermut_LF_simpl.
PPermut_LF_simpl.
rew_app.
eapply IHtypes_LF with (G0:=hd++tl & Gamma') (Gamma0:=Gamma0)(Delta0:=Delta0);
eauto. PPermut_LF_simpl; rew_app.
subst.
apply PPermut_LF_last_rev with (Gamma:=Gamma) (Gamma':=c); auto; rewrite H4;
PPermut_LF_simpl.
intros. rew_app.
eapply H0 with (G0:=((v,A)::nil)::G1) (Gamma0:=Gamma0) (Delta0:=Delta0);
eauto.
rewrite H4; PPermut_LF_simpl.
subst; PPermut_LF_simpl. rewrite H3; subst; PPermut_LF_simpl.
assert (G & Gamma ~=~ Delta0 :: G1).
  transitivity G0; auto.
assert ((Gamma *=* Delta0 /\ G ~=~ G1) \/
        (exists c, exists hd, exists tl, Gamma *=* c /\ G1 = hd & c ++ tl)).
  assert ({Gamma *=* Delta0} + {~ Gamma *=* Delta0}).
  apply permut_dec. intros. destruct k; destruct k'; decide equality.
  apply eq_ty_dec. apply eq_var_dec.
  destruct H4. left; split; auto. apply PPermut_LF_last_rev with (Gamma:=Gamma)
  (Gamma':=Delta0); auto; rewrite H3; PPermut_LF_simpl.
  right.
  assert (G & Gamma ~=~ G1 & Delta0) by (rewrite H3; PPermut_LF_simpl).
  symmetry in H4.
  apply PPermut_LF_split_neq in H4; auto.
  destruct H4 as (Gamma'', (hd, (tl, (H5, H6)))).
  exists Gamma''; exists hd; exists tl; split.
  symmetry; auto. auto.
  intro nn; symmetry in nn; elim n; auto.
destruct H4.
destruct H4.
apply t_letdia_LF with (A:=A)(L:=L).
eapply ok_Bg_LF_concat with (G0:=G1) (G1:=Gamma::G & Gamma')
  (c1:=Gamma')(c2:=Delta0);
eauto; rewrite H5; auto; PPermut_LF_simpl.
apply PermutationGamma_LF with (Gamma:=Gamma++Gamma').
eapply IHtypes_LF; eauto.
rewrite H5; PPermut_LF_simpl. rewrite H4; auto.
intros.
eapply H0; eauto.
rewrite <- H7; rewrite H5; PPermut_LF_simpl.
destruct H4 as (c, (hd, (tl, (H4a, H4)))).
apply t_letdia_get_LF with
  (G:=hd++tl)(Gamma:=Gamma) (L:=L)(A:=A).
eapply ok_Bg_LF_concat with (G0:=Gamma::(hd++tl)) (G1:=Gamma::G & Gamma')
  (c1:=Gamma')(c2:=Delta0);
eauto.
transitivity (G & Gamma & Gamma'); auto; rewrite H3; subst; PPermut_LF_simpl.
PPermut_LF_simpl.
subst. rew_app.
eapply IHtypes_LF with (G0:=hd++tl) (Gamma0:=Gamma')(Delta0:=Delta0);
eauto. PPermut_LF_simpl; apply PPermut_LF_last_rev with (Gamma:=Gamma)
(Gamma':=c);
auto; rewrite H3; PPermut_LF_simpl. PPermut_LF_simpl.
intros; subst; rew_app.
eapply H0; eauto. rewrite H3; PPermut_LF_simpl. subst; PPermut_LF_simpl.
Qed.

Lemma merge_LF_preserv_types_outer:
forall G G0 G1 Gamma Gamma0 Delta0 M A,
  G |= Gamma |- M ::: A ->
  G ~=~ Gamma0 :: Delta0 :: G0 ->
  G1 ~=~ (Gamma0 ++ Delta0) :: G0 ->
  G1 |= Gamma |- M ::: A.
intros; eapply merge_LF_preserv_types; eauto.
Qed.

Lemma merge_LF_preserv_types_new:
forall G G0 Gamma Delta M A,
  G |= Gamma |- M ::: A ->
  G ~=~ Delta::G0 ->
  G0 |= Gamma++Delta |- M ::: A.
intros; eapply merge_LF_preserv_types with (G:=G) (Gamma:=Gamma); eauto.
Qed.

Lemma merge_LF_preserv_types_old:
forall G G0 Gamma Delta M A,
  G |= Delta |- M ::: A ->
  G ~=~ Gamma::G0 ->
  G0 |= Gamma++Delta |- M ::: A.
intros;
apply PermutationGamma_LF with (Gamma:=Delta++Gamma).
eapply merge_LF_preserv_types; eauto.
auto.
Qed.

Lemma Progress_LF:
forall G M A
  (H_lc_t: lc_t_LF M)
  (HT: emptyEquiv_LF G |= nil |- M ::: A),
  value_LF M \/ exists N, M |-> N.
intros;
remember (@nil (var * ty)) as Ctx;
generalize dependent Ctx;
generalize dependent A;
generalize dependent G;
induction M; intros; eauto using value_LF;
inversion HeqCtx; subst.
(* hyp *)
inversion HT; subst.
rewrite Mem_nil_eq in H3;
contradiction.
(* appl *)
right; inversion HT; subst;
inversion H_lc_t; subst;
edestruct IHM1 with (A := A0 ---> A); eauto;
[inversion H0; subst; inversion H4; subst | inversion H0];
eexists; constructor; eauto;
inversion H3; subst; auto.
(* unbox *)
right; inversion HT; subst;
inversion H_lc_t; subst.
edestruct IHM with (A := [*]A); eauto;
[ inversion H0; subst; inversion H3; subst; inversion H3 |
  destruct H0];
eexists; constructor; eauto;
inversion H1; inversion H2; subst; auto.
assert (Gamma = nil) by
  ( apply emptyEquiv_LF_permut_empty with
    (G:= G0 & Gamma) (G':=G); auto;
    apply Mem_last); subst.
destruct IHM with (A := [*]A)
                  (Ctx := (@nil (var * ty)))
                  (G := G0 & nil);
eauto.

assert (emptyEquiv_LF (G0 & nil) = G0 & nil).
  eapply emptyEquiv_LF_PPermut_eq; eauto.
rewrite H0; auto.
inversion H0; subst; inversion H1; subst.
eexists; constructor; eauto. inversion H3; auto; subst.
destruct H0; eexists; econstructor; eauto.
(* here *)
inversion HT; subst;
inversion H_lc_t; subst.
edestruct IHM; eauto;
[left; econstructor | right; destruct H0; eexists];
eauto using step_LF.
assert (Gamma = nil) by
  ( apply emptyEquiv_LF_permut_empty with
    (G:= G0 & Gamma) (G':=G); auto;
    apply Mem_last); subst;
destruct IHM with (A := A0)
                  (Ctx := (@nil (var*ty)))
                  (G := G0 & nil);
eauto.
assert (emptyEquiv_LF (G0 & nil) = G0 & nil) by
  (eapply emptyEquiv_LF_PPermut_eq; eauto).
rewrite H0; auto.
left; inversion H0; subst; inversion H4; subst;
econstructor; eauto using step_LF.
right; destruct H0; eexists;
econstructor; eauto using step_LF.
(* letdia *)
right; inversion HT; subst;
inversion H_lc_t; subst.
edestruct IHM1 with (A := <*>A0); eauto;
[ inversion H0; subst; inversion HT1; subst |
  destruct H0];
eexists; constructor; eauto.
inversion H4; subst; auto.
inversion H4; subst; auto.
assert (Gamma = nil) by
  ( apply emptyEquiv_LF_permut_empty with (G:= G0 & Gamma) (G':=G);
    auto; apply Mem_last); subst;
edestruct IHM1 with (G := G0 & nil)
                    (Ctx := (@nil (var*ty)))
                    (A := <*>A0); eauto;
assert ( emptyEquiv_LF (G0 & nil) = G0 & nil) by
  (eapply emptyEquiv_LF_PPermut_eq; eauto).
rewrite H0; auto.
inversion H0; subst; inversion HT1; subst;
eexists; constructor; eauto;
inversion H4; subst; auto.
destruct H0;
eexists; econstructor; eauto.
Qed.

Lemma Preservation_LF:
forall G M N A
  (HT: emptyEquiv_LF G |= nil |- M ::: A)
  (HS: M |-> N),
  emptyEquiv_LF G |= nil |- N ::: A.
intros; generalize dependent N.
remember (emptyEquiv_LF G) as G';
remember (@nil (var*ty)) as Gamma.
generalize dependent G.
induction HT; intros;
inversion HS; subst;
try (econstructor; eauto).

(* appl_lam *)
inversion HT1; subst;
unfold open_LF in *;
assert (exists v, v \notin L \u used_vars_te_LF M0) as HF by apply Fresh;
destruct HF as (v_fresh);
rewrite subst_t_neutral_free_LF with (v:=v_fresh);
[ eapply subst_t_LF_preserv_types_inner; eauto |
  rewrite notin_union in H; destruct H]; auto;
rewrite <- double_emptyEquiv_LF; auto.

(* unbox_box *)
inversion HT; subst;
replace (@nil (var * ty)) with (nil ++ (@nil (prod var ty)))
  by (rew_app; auto);
apply merge_LF_preserv_types_old with (G:=emptyEquiv_LF G0 & nil);
rew_app; auto.
transitivity (emptyEquiv_LF (G0&nil)).
  rewrite emptyEquiv_LF_rewrite; auto.
  transitivity (emptyEquiv_LF (nil :: G0)); auto.

apply PPermut_emptyEquiv_LF; PPermut_LF_simpl.

inversion HT; subst;
replace (@nil (var * ty)) with (nil ++ (@nil (prod var ty)))
  by (rew_app; auto);
apply merge_LF_preserv_types_old with (G:=G & nil & Gamma);
auto. rewrite <- H; auto.
apply ok_Bg_LF_nil; apply ok_Bg_LF_empty.
assert (Gamma = nil).
  apply emptyEquiv_LF_PPermut in H; auto.
subst. replace (emptyEquiv_LF G0) with (G & nil).
apply IHHT with (G0:=G0); auto.
apply emptyEquiv_LF_PPermut_equal; auto.
apply emptyEquiv_LF_PPermut_equal; auto.

(* here *)
apply ok_Bg_LF_nil; apply ok_Bg_LF_empty.
assert (Gamma = nil).
  apply emptyEquiv_LF_PPermut in H; auto.
subst. replace (emptyEquiv_LF G0) with (G & nil).
apply IHHT with (G0:=G0); auto.
apply emptyEquiv_LF_PPermut_equal; auto.
apply emptyEquiv_LF_PPermut_equal; auto.
inversion HT; subst;
unfold open_LF in *;
assert (exists v, v \notin L \u used_vars_te_LF N) as HF by apply Fresh;
destruct HF as (v_fresh);
rewrite subst_t_neutral_free_LF with (v:=v_fresh);
replace (@nil (var * ty)) with (nil ++ (@nil (prod var ty)))
  by (rew_app; auto).

apply merge_LF_preserv_types_old with (G:=emptyEquiv_LF G0 & nil);
rew_app; auto.
apply subst_t_LF_preserv_types_outer with
  (A:=A) (G:=((v_fresh, A) :: nil) :: emptyEquiv_LF G0) (G0:=emptyEquiv_LF G0)
  (Gamma':=nil) (G':=emptyEquiv_LF G0 & nil); eauto.
PPermut_LF_simpl.
assert (emptyEquiv_LF G0 & nil = emptyEquiv_LF (G0 & nil)).
  rewrite emptyEquiv_LF_rewrite; simpl; auto.
rewrite H1; rewrite <- double_emptyEquiv_LF; rewrite <- H1.
assert (emptyEquiv_LF G0 & nil ~=~ nil::emptyEquiv_LF G0).
  PPermut_LF_simpl.
rewrite H4.
apply WeakeningG_LF; auto.
symmetry;
remember (emptyEquiv_LF G0) as G'.
apply PPermut_LF_first_last.
eauto.
apply merge_LF_preserv_types_old with (G:=emptyEquiv_LF G0 & nil).
apply subst_t_LF_preserv_types_outer with
  (A:=A) (G:=((v_fresh, A) :: nil) :: emptyEquiv_LF G0) (G0:=emptyEquiv_LF G0)
  (Gamma':=nil) (G':=emptyEquiv_LF G0 & nil); eauto.
PPermut_LF_simpl.
replace (emptyEquiv_LF G0 & nil) with (emptyEquiv_LF (G0 & nil)).
rewrite <- double_emptyEquiv_LF.
assert (Gamma = nil).
  apply emptyEquiv_LF_PPermut in H8; auto.
subst.
rewrite emptyEquiv_LF_rewrite; rewrite <- H8; simpl.
apply PPermutationG_LF with (G:=nil :: G & nil); auto;
apply WeakeningG_LF; auto.
rewrite emptyEquiv_LF_rewrite;simpl; auto.
symmetry; apply PPermut_LF_first_last.
eauto.
inversion HT; subst;
unfold open_LF in *;
assert (exists v, v \notin L \u used_vars_te_LF N) as HF by apply Fresh;
destruct HF as (v_fresh);
rewrite subst_t_neutral_free_LF with (v:=v_fresh);
replace (@nil (var * ty)) with (nil ++ (@nil (prod var ty)))
  by (rew_app; auto).
apply merge_LF_preserv_types_old with (G:=emptyEquiv_LF G1 & nil);
rew_app; auto.
apply subst_t_LF_preserv_types_outer with
  (A:=A) (G:=((v_fresh, A) :: nil) :: emptyEquiv_LF G1) (G0:=emptyEquiv_LF G1)
  (Gamma':=nil) (G':=emptyEquiv_LF G1 & nil); eauto.
 PPermut_LF_simpl.
assert (emptyEquiv_LF G1 & nil = emptyEquiv_LF (G1 & nil)).
  rewrite emptyEquiv_LF_rewrite; simpl; auto.
rewrite H2; rewrite <- double_emptyEquiv_LF; rewrite <- H2.
assert (emptyEquiv_LF G1 & nil ~=~ nil::emptyEquiv_LF G1).
  PPermut_LF_simpl.
rewrite H5.
apply WeakeningG_LF; auto.
rewrite <- H0;
assert (Gamma = nil).
  apply emptyEquiv_LF_PPermut in H0; auto.
subst Gamma; auto.
repeat apply ok_Bg_LF_nil; apply ok_Bg_LF_empty.
rewrite <- H0;
apply HT2; eauto.
symmetry; apply PPermut_LF_first_last.
eauto.

apply merge_LF_preserv_types_old with (G:=emptyEquiv_LF G1 & nil);
rew_app; auto.
apply subst_t_LF_preserv_types_outer with
  (A:=A) (G:=((v_fresh, A) :: nil) :: emptyEquiv_LF G1) (G0:=emptyEquiv_LF G1)
  (Gamma':=nil) (G':=emptyEquiv_LF G1 & nil); eauto.
PPermut_LF_simpl.
assert (emptyEquiv_LF G1 & nil = emptyEquiv_LF (G1 & nil)).
  rewrite emptyEquiv_LF_rewrite; simpl; auto.
rewrite H2; rewrite <- double_emptyEquiv_LF; rewrite <- H2.
assert (emptyEquiv_LF G1 & nil ~=~ nil::emptyEquiv_LF G1).
  symmetry; apply PPermut_LF_first_last.
rewrite H5;
apply WeakeningG_LF; rewrite <- H0; auto.
assert (Gamma = nil).
  apply emptyEquiv_LF_PPermut in H0; auto.
subst.
assert (Gamma0 = nil).
  rewrite H0 in H9; apply emptyEquiv_LF_PPermut in H9; auto.
subst.
assert (G0 ~=~ G).
  apply PPermut_LF_last_rev_simpl with (a:=nil); auto.
rewrite <- H9; auto.
repeat apply ok_Bg_LF_nil; rewrite H0; apply ok_Bg_LF_empty.
rewrite <- H0;
apply HT2; eauto.
symmetry; apply PPermut_LF_first_last.
eauto.

apply ok_Bg_LF_nil; apply ok_Bg_LF_empty.
assert (Gamma = nil).
  apply emptyEquiv_LF_PPermut in H0; auto.
subst.
rewrite <- H0. apply IHHT with (G0:=G1); auto.
apply emptyEquiv_LF_PPermut_equal; auto.

intros. unfold open_LF in *.
assert (Gamma = nil).
  apply emptyEquiv_LF_PPermut in H0; auto.
subst.
rewrite <- H2. rewrite <- H0.
apply HT2; eauto.
Qed.

Lemma lc_t_step_LF:
forall M N,
  lc_t_LF M ->
  M |-> N ->
  lc_t_LF N.
induction M; intros; inversion H0; inversion H; subst; try constructor; eauto;
unfold open_LF in *.
apply lc_t_subst_t_LF_bound; auto.
eapply IHM1; eauto.
eapply IHM; eauto.
eapply IHM; eauto.
apply lc_t_subst_t_LF_bound; auto.
eapply IHM1; eauto.
Qed.

Lemma lc_t_steps_LF:
forall M N, lc_t_LF M -> steps_LF M N -> lc_t_LF N.
intros; induction H0.
apply lc_t_step_LF in H0; auto.
apply IHsteps_LF; apply lc_t_step_LF in H0; auto.
Qed.

Lemma value_no_step_LF:
forall M,
  value_LF M ->
  forall N , ~ M |-> N.
induction M; intros; intro;
try inversion H; inversion H0; subst; try inversion H2;
eapply IHM; eauto.
Qed.

Lemma eq_te_LF_dec:
forall (M1: te_LF) (M2: te_LF),
  {M1 = M2} + {M1 <> M2}.
decide equality.
apply eq_vte_dec.
apply eq_ty_dec.
Qed.


From iris.algebra Require Import cmra view auth agree csum list excl gmap.
From iris.algebra.lib Require Import excl_auth gmap_view dfrac_agree.
From iris_ora.algebra Require Import ora osum gmap agree.
From iris_ora.logic Require Import oupred.
From iris.prelude Require Import options.
Import ouPred.

(** Internalized properties of our ORA constructions. *)

Section oupred.
Context {M : uora}.

(* Force implicit argument M *)
Notation "P ⊢ Q" := (bi_entails (PROP:=ouPredI M) P Q).
Notation "P ⊣⊢ Q" := (equiv (A:=ouPredI M) P%I Q%I).
Notation "⊢ Q" := (bi_entails (PROP:=ouPredI M) True Q).

(*Lemma frac_validI (q : Qp) : ✓ q ⊣⊢ ⌜q ≤ 1⌝%Qp.
Proof. rewrite ouPred.discrete_valid frac_valid //. Qed.*)

Section gmap_ofe.
  Context `{Countable K} {A : ofe}.
  Implicit Types m : gmap K A.
  Implicit Types i : K.

  Lemma gmap_equivI m1 m2 : m1 ≡ m2 ⊣⊢ ∀ i, m1 !! i ≡ m2 !! i.
  Proof. by ouPred.unseal. Qed.
End gmap_ofe.

Section gmap_ora.
  Context `{Countable K} {A : ora}.
  Implicit Types m : gmap K A.

  Lemma gmap_validI m : ✓ m ⊣⊢ ∀ i, ✓ (m !! i).
  Proof. by ouPred.unseal. Qed.
  Lemma singleton_validI i x : ✓ ({[ i := x ]} : gmap K A) ⊣⊢ ✓ x.
  Proof.
    rewrite gmap_validI. apply: anti_symm.
    - rewrite (bi.forall_elim i) lookup_singleton option_validI. done.
    - apply bi.forall_intro=>j. destruct (decide (i = j)) as [<-|Hne].
      + rewrite lookup_singleton option_validI. done.
      + rewrite lookup_singleton_ne // option_validI.
        apply bi.True_intro.
  Qed.
End gmap_ora.

Section list_ofe.
  Context {A : ofe}.
  Implicit Types l : list A.

  Lemma list_equivI l1 l2 : l1 ≡ l2 ⊣⊢ ∀ i, l1 !! i ≡ l2 !! i.
  Proof. ouPred.unseal; constructor=> n x ?. apply list_dist_lookup. Qed.
End list_ofe.

(*Section excl.
  Context {A : ofe}.
  Implicit Types a b : A.
  Implicit Types x y : excl A.

  Lemma excl_equivI x y :
    x ≡ y ⊣⊢ match x, y with
                        | Excl a, Excl b => a ≡ b
                        | ExclBot, ExclBot => True
                        | _, _ => False
                        end.
  Proof.
    ouPred.unseal. do 2 split.
    - by destruct 1.
    - by destruct x, y; try constructor.
  Qed.
  Lemma excl_validI x :
    ✓ x ⊣⊢ if x is ExclBot then False else True.
  Proof. ouPred.unseal. by destruct x. Qed.
End excl.*)

Section agree.
  Context {A : ofe}.
  Implicit Types a b : A.
  Implicit Types x y : agree A.

  Lemma agree_equivI a b : to_agree a ≡ to_agree b ⊣⊢ (a ≡ b).
  Proof.
    ouPred.unseal. do 2 split.
    - intros Hx. exact: (inj to_agree).
    - intros Hx. exact: to_agree_ne.
  Qed.
  Lemma agree_validI x y : ✓ (x ⋅ y) ⊢ x ≡ y.
  Proof. ouPred.unseal; split=> r n _ ?; by apply: agree_op_invN. Qed.

  Lemma to_agree_validI a : ⊢ ✓ to_agree a.
  Proof. ouPred.unseal; done. Qed.
  Lemma to_agree_op_validI a b : ✓ (to_agree a ⋅ to_agree b) ⊣⊢ a ≡ b.
  Proof.
    apply bi.entails_anti_sym.
    - rewrite agree_validI. by rewrite agree_equivI.
    - pose (Ψ := (λ x : A, ✓ (to_agree a ⋅ to_agree x) : ouPred M)%I).
      assert (NonExpansive Ψ) as ? by solve_proper.
      rewrite (internal_eq_rewrite a b Ψ).
      eapply bi.impl_elim; first reflexivity.
      etrans; first apply bi.True_intro.
      subst Ψ; simpl.
      rewrite agree_idemp. apply to_agree_validI.
  Qed.

  Lemma to_agree_uninjI x : ✓ x ⊢ ∃ a, to_agree a ≡ x.
  Proof. ouPred.unseal. split=> n y _. exact: to_agree_uninjN. Qed.
End agree.

Section csum_ofe.
  Context {A B : ofe}.
  Implicit Types a : A.
  Implicit Types b : B.

  Lemma csum_equivI (x y : csum A B) :
    x ≡ y ⊣⊢ match x, y with
                        | Cinl a, Cinl a' => a ≡ a'
                        | Cinr b, Cinr b' => b ≡ b'
                        | CsumBot, CsumBot => True
                        | _, _ => False
                        end.
  Proof.
    ouPred.unseal; do 2 split; first by destruct 1.
      by destruct x, y; try destruct 1; try constructor.
  Qed.
End csum_ofe.

Section csum_ora.
  Context {A B : ora}.
  Implicit Types a : A.
  Implicit Types b : B.

  Lemma csum_validI (x : csum A B) :
    ✓ x ⊣⊢ match x with
                      | Cinl a => ✓ a
                      | Cinr b => ✓ b
                      | CsumBot => False
                      end.
  Proof. ouPred.unseal. by destruct x. Qed.
End csum_ora.

(*Section view.
  Context {A B} (rel : view_rel A B).
  Implicit Types a : A.
  Implicit Types ag : option (frac * agree A).
  Implicit Types b : B.
  Implicit Types x y : view rel.

  Lemma view_both_dfrac_validI_1 (relI : ouPred M) dq a b :
    (∀ n (x : M), rel n a b → relI n x) →
    ✓ (●V{dq} a ⋅ ◯V b : view rel) ⊢ ⌜✓dq⌝ ∧ relI.
  Proof.
    intros Hrel. ouPred.unseal. split=> n x _ /=.
    rewrite /ouPred_holds /= view_both_dfrac_validN. by move=> [? /Hrel].
  Qed.
  Lemma view_both_dfrac_validI_2 (relI : ouPred M) dq a b :
    (∀ n (x : M), relI n x → rel n a b) →
    ⌜✓dq⌝ ∧ relI ⊢ ✓ (●V{dq} a ⋅ ◯V b : view rel).
  Proof.
    intros Hrel. ouPred.unseal. split=> n x _ /=.
    rewrite /ouPred_holds /= view_both_dfrac_validN. by move=> [? /Hrel].
  Qed.
  Lemma view_both_dfrac_validI (relI : ouPred M) dq a b :
    (∀ n (x : M), rel n a b ↔ relI n x) →
    ✓ (●V{dq} a ⋅ ◯V b : view rel) ⊣⊢ ⌜✓dq⌝ ∧ relI.
  Proof.
    intros. apply (anti_symm _);
      [apply view_both_dfrac_validI_1|apply view_both_dfrac_validI_2]; naive_solver.
  Qed.

  Lemma view_both_validI_1 (relI : ouPred M) a b :
    (∀ n (x : M), rel n a b → relI n x) →
    ✓ (●V a ⋅ ◯V b : view rel) ⊢ relI.
  Proof. intros. by rewrite view_both_dfrac_validI_1 // bi.and_elim_r. Qed.
  Lemma view_both_validI_2 (relI : ouPred M) a b :
    (∀ n (x : M), relI n x → rel n a b) →
    relI ⊢ ✓ (●V a ⋅ ◯V b : view rel).
  Proof.
    intros. rewrite -view_both_dfrac_validI_2 //.
    apply bi.and_intro; [|done]. by apply bi.pure_intro.
  Qed.
  Lemma view_both_validI (relI : ouPred M) a b :
    (∀ n (x : M), rel n a b ↔ relI n x) →
    ✓ (●V a ⋅ ◯V b : view rel) ⊣⊢ relI.
  Proof.
    intros. apply (anti_symm _);
      [apply view_both_validI_1|apply view_both_validI_2]; naive_solver.
  Qed.

  Lemma view_auth_dfrac_validI (relI : ouPred M) dq a :
    (∀ n (x : M), relI n x ↔ rel n a ε) →
    ✓ (●V{dq} a : view rel) ⊣⊢ ⌜✓dq⌝ ∧ relI.
  Proof.
    intros. rewrite -(right_id ε op (●V{dq} a)). by apply view_both_dfrac_validI.
  Qed.
  Lemma view_auth_validI (relI : ouPred M) a :
    (∀ n (x : M), relI n x ↔ rel n a ε) →
    ✓ (●V a : view rel) ⊣⊢ relI.
  Proof. intros. rewrite -(right_id ε op (●V a)). by apply view_both_validI. Qed.

  Lemma view_frag_validI (relI : ouPred M) b :
    (∀ n (x : M), relI n x ↔ ∃ a, rel n a b) →
    ✓ (◯V b : view rel) ⊣⊢ relI.
  Proof. ouPred.unseal=> Hrel. split=> n x _. by rewrite Hrel. Qed.
End view.

Section auth.
  Context {A : uora}.
  Implicit Types a b : A.
  Implicit Types x y : auth A.

  Lemma auth_auth_dfrac_validI dq a : ✓ (●{dq} a) ⊣⊢ ⌜✓dq⌝ ∧ ✓ a.
  Proof.
    apply view_auth_dfrac_validI=> n. ouPred.unseal; split; [|by intros [??]].
    split; [|done]. apply uora_unit_leastN.
  Qed.
  Lemma auth_auth_validI a : ✓ (● a) ⊣⊢ ✓ a.
  Proof.
    by rewrite auth_auth_dfrac_validI bi.pure_True // left_id.
  Qed.

  Lemma auth_frag_validI a : ✓ (◯ a) ⊣⊢ ✓ a.
  Proof.
    apply view_frag_validI=> n x.
    rewrite auth_view_rel_exists. by ouPred.unseal.
  Qed.

  Lemma auth_both_dfrac_validI dq a b :
    ✓ (●{dq} a ⋅ ◯ b) ⊣⊢ ⌜✓dq⌝ ∧ (∃ c, a ≡ b ⋅ c) ∧ ✓ a.
  Proof. apply view_both_dfrac_validI=> n. by ouPred.unseal. Qed.
  Lemma auth_both_validI a b :
    ✓ (● a ⋅ ◯ b) ⊣⊢ (∃ c, a ≡ b ⋅ c) ∧ ✓ a.
  Proof.
    by rewrite auth_both_dfrac_validI bi.pure_True // left_id.
  Qed.

End auth.

Section excl_auth.
  Context {A : ofe}.
  Implicit Types a b : A.

  Lemma excl_auth_agreeI a b : ✓ (●E a ⋅ ◯E b) ⊢ (a ≡ b).
  Proof.
    rewrite auth_both_validI bi.and_elim_l.
    apply bi.exist_elim=> -[[c|]|];
      by rewrite option_equivI /= excl_equivI //= bi.False_elim.
  Qed.
End excl_auth.

Section dfrac_agree.
  Context {A : ofe}.
  Implicit Types a b : A.

  Lemma dfrac_agree_validI dq a : ✓ (to_dfrac_agree dq a) ⊣⊢ ⌜✓ dq⌝.
  Proof.
    rewrite prod_validI /= ouPred.discrete_valid. apply bi.entails_anti_sym.
    - by rewrite bi.and_elim_l.
    - apply bi.and_intro; first done. etrans; last apply to_agree_validI.
      apply bi.True_intro.
  Qed.

  Lemma dfrac_agree_validI_2 dq1 dq2 a b :
    ✓ (to_dfrac_agree dq1 a ⋅ to_dfrac_agree dq2 b) ⊣⊢ ⌜✓ (dq1 ⋅ dq2)⌝ ∧ (a ≡ b).
  Proof.
    rewrite prod_validI /= ouPred.discrete_valid to_agree_op_validI //.
  Qed.

  Lemma frac_agree_validI q a : ✓ (to_frac_agree q a) ⊣⊢ ⌜(q ≤ 1)%Qp⌝.
  Proof.
    rewrite dfrac_agree_validI dfrac_valid_own //.
  Qed.

  Lemma frac_agree_validI_2 q1 q2 a b :
    ✓ (to_frac_agree q1 a ⋅ to_frac_agree q2 b) ⊣⊢ ⌜(q1 + q2 ≤ 1)%Qp⌝ ∧ (a ≡ b).
  Proof.
    rewrite dfrac_agree_validI_2 dfrac_valid_own //.
  Qed.
End dfrac_agree.

Section gmap_view.
  Context {K : Type} `{Countable K} {V : ofe}.
  Implicit Types (m : gmap K V) (k : K) (dq : dfrac) (v : V).

  Lemma gmap_view_both_validI m k dq v :
    ✓ (gmap_view_auth (DfracOwn 1) m ⋅ gmap_view_frag k dq v) ⊢
    ✓ dq ∧ m !! k ≡ Some v.
  Proof.
    rewrite /gmap_view_auth /gmap_view_frag. apply view_both_validI_1.
    intros n a. ouPred.unseal. apply gmap_view.gmap_view_rel_lookup.
  Qed.

  Lemma gmap_view_frag_op_validI k dq1 dq2 v1 v2 :
    ✓ (gmap_view_frag k dq1 v1 ⋅ gmap_view_frag k dq2 v2) ⊣⊢
    ✓ (dq1 ⋅ dq2) ∧ v1 ≡ v2.
  Proof.
    rewrite /gmap_view_frag -view_frag_op. apply view_frag_validI=> n x.
    rewrite gmap_view.gmap_view_rel_exists singleton_op singleton_validN.
    rewrite -pair_op pair_validN to_agree_op_validN. by ouPred.unseal.
  Qed.

End gmap_view.*)

End oupred.


Require Export Coq.Bool.Bool.
Require Export Coq.Arith.Arith.
Require Export Coq.Arith.EqNat.
Require Export Coq.omega.Omega.
Require Export Coq.ZArith.ZArith.
Require Export Coq.Numbers.Natural.Peano.NPeano.
Require Export Coq.Setoids.Setoid.
Require Export Coq.Program.Equality. (**r Necessary for 'dependent induction'. *)

Ltac autoinjection :=
  repeat match goal with
           | h: ?f _ = ?f _ |- _ => injection h; intros; clear h; subst
           | h: ?f _ _ = ?f _  _ |- _ => injection h; intros; clear h; subst
           | h: ?f _ _ _ = ?f _ _ _ |- _ => injection h; intros; clear h; subst
           | h: ?f _ _ _ _ = ?f _ _ _ _ |- _ => injection h; intros; clear h; subst
           | h: ?f _ _ _ _ _ = ?f _ _ _ _ _ |- _ => injection h; intros; clear h; subst
         end.

Ltac go :=
  simpl in *;
  repeat match goal with
           | h: ?x = _ |- context[match ?x with _ => _ end] => rewrite h
         end;
  autoinjection;
  try (congruence);
  try omega;
  subst;
  eauto 4 with zarith datatypes;
  try (econstructor ; (solve[go])).

Tactic Notation "go" := try (go; fail).

Ltac go_with b :=
  simpl in *;
  repeat match goal with
           | h: ?x = _ |- context[match ?x with _ => _ end] => rewrite h
         end;
  autoinjection;
  try (congruence);
  try omega;
  subst;
  eauto 4 with zarith datatypes b;
  try (econstructor ; (solve[go])).

Ltac inv H := inversion H; try subst; clear H.

Tactic Notation "flatten" ident(H) :=
  repeat match goal with
    | H: context[match ?x with | left _ => _ | right _ => _ end] |- _ => destruct x
    | H: context[match ?x with | _ => _ end] |- _ => let E := fresh "Eq" in destruct x eqn:E
  end; autoinjection; try congruence.

Tactic Notation "flatten" :=
  repeat match goal with
    | |- context[match ?x with | left _ => _ | right _ => _ end] => destruct x
    | |- context[match ?x with | _ => _ end] => let E := fresh "Eq" in destruct x eqn:E
  end; autoinjection; try congruence.

(*Tactic Notation "induction" ident(x) := dependent induction x.*)

(* Definition admit {T: Type} : T. Admitted.
 *)
Tactic Notation "solve_by_inversion_step" tactic(t) :=
  match goal with
  | H : _ |- _ => solve [ inversion H; subst; t ]
  end
  || fail "because the goal is not solvable by inversion.".

Tactic Notation "solve" "by" "inversion" "1" :=
  solve_by_inversion_step idtac.
Tactic Notation "solve" "by" "inversion" "2" :=
  solve_by_inversion_step (solve by inversion 1).
Tactic Notation "solve" "by" "inversion" "3" :=
  solve_by_inversion_step (solve by inversion 2).
Tactic Notation "solve" "by" "inversion" :=
  solve by inversion 1.


(* 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                                                     *)

(*****************************************************************************)
(*          Projet Formel - Calculus of Inductive Constructions V5.10        *)
(*****************************************************************************)
(*									     *)
(*	    Limits by Producys and equalizers              		     *)
(*									     *)
(*****************************************************************************)
(*									     *)
(*                        A.SAIBI         May 95			     *)
(*									     *)
(*****************************************************************************)

Require Export Equalizers1.
Require Export Products1.

Set Implicit Arguments.
Unset Strict Implicit.

Section thl.

Variables (C J : Category) (H1 : forall k : J -> C, Product1 k)
  (H2 : forall k : Arrs J -> C, Product1 k)
  (H3 : forall (a b : C) (f g : a --> b), Equalizer1_fg f g)
  (F : Functor J C).

Let Limit2_fg (a b : C) (f g : a --> b) := Build_Equalizer2 (H3 f g) Elt1.

(* IIi Fi *)

Definition Thl_k_Fi (i : J) := F i.

Definition Thl_l_Fi := H1 Thl_k_Fi.

Definition Thl_PI_Fi := Pi1 Thl_l_Fi.

(* ||u F(codomu) *)

Definition Thl_k_Fu (u : Arrs J) := F (Codom u).

Definition Thl_l_Fu := H2 Thl_k_Fu.

Definition Thl_PI_Fu := Pi1 Thl_l_Fu.

(* qq u. fu : IIi Fi -> ku (= F(codomu)) *)

Definition Thl_fu (u : Arrs J) := Proj1 Thl_l_Fi (Codom u).

(* donc E! f : IIi Fi -> ||u F(codomu) tq ... *)

Definition Thl_f : Thl_PI_Fi --> Thl_PI_Fu := Pd1_diese Thl_l_Fu Thl_fu.

Lemma Thl_diag1 : forall u : Arrs J, Thl_fu u =_S Thl_f o Proj1 Thl_l_Fu u.
Proof.
exact (Prf_pd1_law1 Thl_l_Fu Thl_fu).
Qed.

(* qq u. gu : IIi Fi --p(domu)--> F(domu) --Fu--> ku (= F(codomu)) *)

Definition Thl_gu (u : Arrs J) := Proj1 Thl_l_Fi (Dom u) o FMor F (Arrow u).

(* donc E! g : IIi Fi -> ||u F(codomu) tq ... *)

Definition Thl_g := Pd1_diese Thl_l_Fu Thl_gu.

Lemma Thl_diag2 : forall u : Arrs J, Thl_gu u =_S Thl_g o Proj1 Thl_l_Fu u.
Proof.
exact (Prf_pd1_law1 Thl_l_Fu Thl_gu).
Qed.

(* equalizer de f et g *)

Definition Thl_l_fg := Limit2_fg Thl_f Thl_g.

Definition Thl_d := E1_ob Thl_l_fg.

Definition Thl_e := E1_mor Thl_l_fg.

(* construction du limiting cone *)

Definition Thl_mu_tau (j : J) := Thl_e o Proj1 Thl_l_Fi j.

Lemma Thl_mu_cone_law : Cone_law Thl_mu_tau.
Proof.
unfold Cone_law in |- *; intros j k u; unfold Thl_mu_tau in |- *.
(* *) apply Trans with (Thl_e o Thl_f o Proj1 Thl_l_Fu (Build_Arrs u)).
apply Comp_l.
apply (Thl_diag1 (Build_Arrs u)).
(* *) apply Trans with (Thl_e o Proj1 Thl_l_Fi j o FMor F u).
(* *) apply Trans with (Thl_e o Thl_g o Proj1 Thl_l_Fu (Build_Arrs u)).
(* *) apply Trans with ((Thl_e o Thl_f) o Proj1 Thl_l_Fu (Build_Arrs u)).
apply Ass.
(* *) apply Trans with ((Thl_e o Thl_g) o Proj1 Thl_l_Fu (Build_Arrs u)).
apply Comp_r.
apply (Prf_E1_law1 Thl_l_fg Elt1 Elt2).
apply Ass1.
apply Comp_l.
apply Sym.
exact (Thl_diag2 (Build_Arrs u)).
apply Ass.
Qed.

Definition Thl_mu := Build_Cone Thl_mu_cone_law.

 Section taudiese.

 (* construction de l'ope'ration # *)

 Variables (c : C) (tau : Cone c F).

 (* Bug trad *)

 Definition Thl_h := Pd1_diese Thl_l_Fi (c:=c) (fun i : J => tau i).

 Lemma Thl_diag3 : forall i : J, tau i =_S Thl_h o Proj1 Thl_l_Fi i.
 Proof.
 intro i; apply (Prf_pd1_law1 Thl_l_Fi (r:=c) (fun i : J => tau i) i).
 Qed.

 (* hof = hog *)
 (* hof = (IIFcodu)# (+) *)
 (* tau(codu) = h o p(codu)   Thl_diag3 *)
 (*           = h o f o p(u)  Thl_diag1 *)
 (* on a (+) par unicite' de IIFcodu *)

 (* hog = (IIFcodu)# (**) *)
 (* p(domu) o Fu = g o p(u) Thl_diag2 *)
 (* h o p(domu) o Fu = h o g o p(u) *)
 (* tau(domu)   o Fu = h o g o p(u) Thl_diag3 *)
 (* tau(codomu)      = h o f o p(u) tau est un cone *)

 Lemma Thl_diag4 : Thl_h o Thl_f =_S Thl_h o Thl_g.
 Proof.
 (* *) apply
        Trans
         with (Pd1_diese Thl_l_Fu (c:=c) (fun u : Arrs J => tau (Codom u))).
 apply
  (Prf_pd1_law2 (l:=Thl_l_Fu) (r:=c) (h:=fun u : Arrs J => tau (Codom u))).
 unfold Product_eq in |- *; intro u.
 (* *) apply Trans with (Thl_h o Proj1 Thl_l_Fi (Codom u)).
 apply (Thl_diag3 (Codom u)).
 (* *) apply Trans with (Thl_h o Thl_f o Proj1 Thl_l_Fu u).
 apply Comp_l.
 apply (Thl_diag1 u).
 apply Ass.
 apply Sym.
 apply
  (Prf_pd1_law2 (l:=Thl_l_Fu) (r:=c) (h:=fun u : Arrs J => tau (Codom u))).
 unfold Product_eq in |- *; intro u.
 (* *) apply Trans with (tau (Dom u) o FMor F (Arrow u)).
 apply (Eq_cone tau (Arrow u)).
 (* *) apply Trans with ((Thl_h o Proj1 Thl_l_Fi (Dom u)) o FMor F (Arrow u)).
 apply Comp_r.
 apply (Thl_diag3 (Dom u)).
 (* *) apply Trans with (Thl_h o Proj1 Thl_l_Fi (Dom u) o FMor F (Arrow u)).
 apply Ass1.
 (* *) apply Trans with (Thl_h o Thl_g o Proj1 Thl_l_Fu u).
 apply Comp_l.
 apply (Thl_diag2 u).
 apply Ass.
 Qed.

 (* posons tau# = h# *)

 Definition Thl_diese := E1_diese Thl_l_fg (Prf_law1_fg Thl_diag4).

 End taudiese.

(* universalite' *)

Lemma Thl_limit1 : Limit_law1 Thl_mu Thl_diese.
Proof.
unfold Limit_law1, Limit_eq in |- *; intros c tau; simpl in |- *; intro i.
(* *) apply Trans with ((Thl_diese tau o Thl_e) o Proj1 Thl_l_Fi i).
(* *) apply Trans with (Thl_diese tau o Thl_e o Proj1 Thl_l_Fi i).
apply Refl.
apply Ass.
(* *) apply
       Trans
        with
          (Pd1_diese Thl_l_Fi (c:=c) (fun i : J => tau i) o Proj1 Thl_l_Fi i).
apply Comp_r.
apply Sym.
apply (Prf_E1_law2 Thl_l_fg (Prf_law1_fg (Thl_diag4 tau))).
apply Sym.
apply (Thl_diag3 tau i).
Qed.

(* hyp: t o mu(i) = tau(i) *)
(* s` prouver: t = tau# (=h#) *)
(* par universalite' de e, revient a` prouver:
   h = t o e
   or, (rappel) h =def (i|->tau(i))# pour ||Fi
   donc par universalite' de IIFi, revient a` prouver:
   qq i:Ob(J). tau(i) = t o e o p(i)
   vrai par hyp car mu(i) =def e o p(i) *)

Lemma Thl_limit2 : Limit_law2 Thl_mu Thl_diese.
Proof.
unfold Limit_law2, Limit_eq in |- *; intros c tau t H.
unfold Thl_diese in |- *; apply (Prf_E1_law3 (l:=Thl_l_fg)).
apply Sym.
unfold Thl_h in |- *.
apply (Prf_pd1_law2 (l:=Thl_l_Fi)); unfold Product_eq in |- *; intro i.
apply Trans with (t o Thl_e o Proj1 Thl_l_Fi i).
apply Sym.
exact (H i).
apply Ass.
Qed.

Definition Thl_islimit := Build_IsLimit Thl_limit1 Thl_limit2.

Definition Thl_limit := Build_Limit Thl_islimit.

End thl.


(* Check that metas are whd-normalized before trying 2nd-order unification *)
Lemma test :
  forall (D:Type) (T : forall C, option C) (Q:forall D, option D -> Prop),
  (forall (A : Type) (P : forall B:Type, option B -> Prop), P A (T A))
  -> Q D (T D).
Proof.
  intros D T Q H.
  pattern (T D). apply H.
Qed.


(* 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                                                     *)

(* A directed graph -Digraph- is a type dependant of a set of           *)
(* vertices and a set of arcs. An inhabitant of such a type is a        *)
(* construction, inductively defined, of this graph. Some Digraphs      *)
(* are not inhabited.                                                   *)

(* The following notions are defined :                                  *)
(*      - (Digraph v a) : set of directed graph with vertices in v      *)
(*                              and arcs in a,                          *)
(*              constructors : D_empty, D_vertex, D_arc, D_eq;          *)
(*      - DV_list : list of vertices of a Digraph;                      *)
(*      - DA_list : list of arcs of a Digraph;                          *)
(*      - D_oreder : number of vertices;                                *)
(*      - D_size : number of arcs.                                      *)

Require Export Arcs.

Section DIGRAPH.

Inductive Digraph : V_set -> A_set -> Type :=
  | D_empty : Digraph V_empty A_empty
  | D_vertex :
      forall (v : V_set) (a : A_set) (d : Digraph v a) (x : Vertex),
      ~ v x -> Digraph (V_union (V_single x) v) a
  | D_arc :
      forall (v : V_set) (a : A_set) (d : Digraph v a) (x y : Vertex),
      v x ->
      v y ->
      ~ a (A_ends x y) -> Digraph v (A_union (A_single (A_ends x y)) a)
  | D_eq :
      forall (v v' : V_set) (a a' : A_set),
      v = v' -> a = a' -> Digraph v a -> Digraph v' a'.

Fixpoint DV_list (v : V_set) (a : A_set) (d : Digraph v a) {struct d} :
 V_list :=
  match d with
  | D_empty => V_nil
  | D_vertex v' a' d' x _ => x :: DV_list v' a' d'
  | D_arc v' a' d' x y _ _ _ => DV_list v' a' d'
  | D_eq v v' a a' _ _ d => DV_list v a d
  end.

Fixpoint DA_list (v : V_set) (a : A_set) (d : Digraph v a) {struct d} :
 A_list :=
  match d with
  | D_empty => A_nil
  | D_vertex v' a' d' x _ => DA_list v' a' d'
  | D_arc v' a' d' x y _ _ _ => A_ends x y :: DA_list v' a' d'
  | D_eq v v' a a' _ _ d => DA_list v a d
  end.

Definition D_order (v : V_set) (a : A_set) (d : Digraph v a) :=
  length (DV_list v a d).

Definition D_size (v : V_set) (a : A_set) (d : Digraph v a) :=
  length (DA_list v a d).
Lemma D_v_dec :
 forall (v : V_set) (a : A_set) (d : Digraph v a) (x : Vertex),
 {v x} + {~ v x}.
Proof.
        intros v a d; induction d as [ |v a d H x Hneg| |v v' a a' e ? d H]; intros.
        right; apply V_empty_nothing.

        case (H x0); intros H0.
        left; apply V_in_right; trivial.

        case (V_eq_dec x x0); intros H1.
        left; apply V_in_left; rewrite H1; apply V_in_single.

        right; red; intros H2; inversion H2.
        elim H1; inversion H3; trivial.

        elim H0; trivial.

        auto.

        destruct (H x).
        left; elim e; trivial.

        right; elim e; trivial.
Qed.

Lemma D_a_dec :
 forall (v : V_set) (a : A_set) (d : Digraph v a) (x : Arc), {a x} + {~ a x}.
Proof.
        intros v a d; elim d; intros.
        right; apply A_empty_nothing.

        auto.

        case (H x0); intros H0.
        left; apply A_in_right; trivial.

        case (A_eq_dec (A_ends x y) x0); intros H1.
        left; apply A_in_left; rewrite H1; apply A_in_single.

        right; red; intros H2; inversion H2 as [x1 H3|].
        elim H1; inversion H3; trivial.

        elim H0; trivial.

        case (H x); intros.
        left; elim e0; trivial.

        right; elim e0; trivial.
Qed.

End DIGRAPH.

Section UNION_DIGRAPHS.

Lemma D_union :
 forall (v1 v2 : V_set) (a1 a2 : A_set),
 Digraph v1 a1 -> Digraph v2 a2 -> Digraph (V_union v1 v2) (A_union a1 a2).
 Admitted.
(*
Proof.
        intros; elim H; intros.
        apply D_eq with (v := v2) (a := a2).
        symmetry ; apply V_union_neutral.

        symmetry ; apply A_union_neutral.

        trivial.

        case (D_v_dec v2 a2 H0 x); intros.
        apply D_eq with (v := V_union v v2) (a := A_union a a2).
        rewrite V_union_assoc; rewrite (V_union_absorb (V_single x)); trivial.
        apply V_included_single; apply V_in_right; trivial.

        trivial.

        trivial.

        apply
         D_eq
          with (v := V_union (V_single x) (V_union v v2)) (a := A_union a a2).
        symmetry ; apply V_union_assoc.

        trivial.

        apply D_vertex.
        trivial.

        apply V_not_union; trivial.

        case (D_a_dec v2 a2 H0 (A_ends x y)); intros.
        apply D_eq with (v := V_union v v2) (a := A_union a a2).
        trivial.

        rewrite A_union_assoc;
         rewrite (A_union_absorb (A_single (A_ends x y)));
         trivial.
        apply A_included_single; apply A_in_right; trivial.

        trivial.

        apply
         D_eq
          with
            (v := V_union v v2)
            (a := A_union (A_single (A_ends x y)) (A_union a a2)).
        trivial.

        symmetry ; apply A_union_assoc.

        apply D_arc.
        trivial.

        apply V_in_left; trivial.

        apply V_in_left; trivial.

        apply A_not_union; trivial.

        apply D_eq with (v := V_union v v2) (a := A_union a a2).
        elim e; trivial.

        elim e0; trivial.

        trivial.
Qed.*)

End UNION_DIGRAPHS.


Require Import sflib.
From Paco Require Import paco.

Require Import Axioms.
Require Import Basic.
Require Import Loc.
Require Import Language.

Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import MemoryFacts.
Require Import TView.
Require Import Local.
Require Import Thread.

Require Import MemorySplit.
Require Import MemoryMerge.

Set Implicit Arguments.

Inductive fulfill_step (lc1:Local.t) (sc1:TimeMap.t) (loc:Loc.t) (from to:Time.t) (val:Const.t) (releasedm released:option View.t) (ord:Ordering.t): forall (lc2:Local.t) (sc2:TimeMap.t), Prop :=
| step_fulfill
    promises2
    (REL_LE: View.opt_le (TView.write_released (Local.tview lc1) sc1 loc to releasedm ord) released)
    (REL_WF: View.opt_wf released)
    (WRITABLE: TView.writable (TView.cur (Local.tview lc1)) sc1 loc to ord)
    (REMOVE: Memory.remove (Local.promises lc1) loc from to (Message.concrete val released) promises2)
    (TIME: Time.lt from to):
    fulfill_step lc1 sc1 loc from to val releasedm released ord
                 (Local.mk (TView.write_tview (Local.tview lc1) sc1 loc to ord) promises2)
                 sc1
.

Lemma fulfill_step_future lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2
      (STEP: fulfill_step lc1 sc1 loc from to val releasedm released ord lc2 sc2)
      (REL: Memory.closed_opt_view releasedm mem1)
      (WF1: Local.wf lc1 mem1)
      (CLOSED1: Memory.closed mem1):
  <<WF2: Local.wf lc2 mem1>> /\
  <<SC_FUTURE: TimeMap.le sc1 sc2>>.
Proof.
  inv STEP.
  hexploit Memory.remove_future; try apply REMOVE; try apply WF1; eauto. i. des.
  exploit Memory.remove_get0; eauto. i. des.
  inversion WF1. exploit PROMISES; eauto. i.
  exploit TViewFacts.write_future_fulfill; try apply x; try apply SC1; try apply WF1; eauto.
  { inv CLOSED1. exploit CLOSED; eauto. i. des. inv MSG_CLOSED. eauto. }
  i. des.
  esplits; eauto; try refl.
  econs; eauto; ss.
  ii. erewrite Memory.remove_o; eauto. condtac; ss.
Qed.

Lemma fulfill_step_cap
      lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2
      mem2
      (STEP: fulfill_step lc1 sc1 loc from to val releasedm released ord lc2 sc2)
      (CAP: Memory.cap mem1 mem2):
  Memory.cap mem1 mem2.
Proof.
  inv STEP. destruct lc1. ss.
Qed.

Lemma write_promise_fulfill
      lc0 sc0 mem0 loc from to val releasedm released ord lc2 sc2 mem2 kind lo
      (WRITE: Local.write_step lc0 sc0 mem0 loc from to val releasedm released ord lc2 sc2 mem2 kind lo)
      (REL_WF: View.opt_wf releasedm)
      (REL_CLOSED: Memory.closed_opt_view releasedm mem0)
      (WF0: Local.wf lc0 mem0)
      (MEM0: Memory.closed mem0):
  exists lc1,
    <<STEP1: Local.promise_step lc0 mem0 loc from to (Message.concrete val released) lc1 mem2 kind>> /\
    <<STEP2: fulfill_step lc1 sc0 loc from to val releasedm released ord lc2 sc2>> /\
    <<REL: released = TView.write_released (Local.tview lc0) sc0 loc to releasedm ord>> /\
    <<ORD: Ordering.le Ordering.strong_relaxed ord -> Memory.nonsynch_loc loc (Local.promises lc0)>>.
Proof.
  exploit Local.write_step_future; eauto. i. des.
  inv WRITE. inv WRITE0. esplits; eauto.
  refine (step_fulfill _ _ _ _ _ _ _); auto.
  - refl.
  - eapply MemoryFacts.promise_time_lt; eauto.
    inv PROMISE; ss.
Qed.

Lemma write_promise_fulfill_na_write
      lc0 sc0 mem0 loc from to val released lc2 sc2 mem2 kind lo
      (WRITE: Local.write_step lc0 sc0 mem0 loc from to val None released Ordering.plain lc2 sc2 mem2 kind lo):
  exists lc1,
    <<STEP1: Local.promise_step lc0 mem0 loc from to (Message.concrete val released) lc1 mem2 kind>> /\
    <<STEP2: fulfill_step lc1 sc0 loc from to val None released Ordering.plain lc2 sc2>> /\
    <<REL: released = TView.write_released (Local.tview lc0) sc0 loc to None Ordering.plain>>.
Proof.
  inv WRITE. inv WRITE0. esplits; eauto.
  refine (step_fulfill _ _ _ _ _ _ _); auto.
  eapply MemoryFacts.promise_time_lt; eauto.
  inv PROMISE; ss.
Qed.

Lemma promise_fulfill_write
      lc0 sc0 mem0 loc from to val releasedm released ord lc1 lc2 sc2 mem2 kind lo
      (PROMISE: Local.promise_step lc0 mem0 loc from to (Message.concrete val released) lc1 mem2 kind)
      (FULFILL: fulfill_step lc1 sc0 loc from to val releasedm released ord lc2 sc2)
      (REL_WF: View.opt_wf releasedm)
      (REL_CLOSED: Memory.closed_opt_view releasedm mem0)
      (ORD: Ordering.le Ordering.strong_relaxed ord -> Memory.nonsynch_loc loc (Local.promises lc0))
      (WF0: Local.wf lc0 mem0)
      (MEM0: Memory.closed mem0)
      (REL: released = TView.write_released (Local.tview lc0) sc0 loc to releasedm ord)
      (ORDER_MATCH: Ordering.mem_ord_match ord (lo loc)):
  Local.write_step lc0 sc0 mem0 loc from to val releasedm released ord lc2 sc2 mem2 kind lo.
Proof.
  exploit Local.promise_step_future; eauto. i. des.
  inv PROMISE. inv FULFILL.
  exploit MemorySplit.remove_promise_remove;
    try exact REMOVE; eauto; try apply WF2; try refl.
Qed.

Lemma fulfill_step_promises_diff
      lc1 sc1 loc1 from to val releasedm released ord lc2 sc2 loc2
      (LOC: loc1 <> loc2)
      (FULFILL: fulfill_step lc1 sc1 loc1 from to val releasedm released ord lc2 sc2):
  (Local.promises lc1) loc2 = (Local.promises lc2) loc2.
Proof.
  inv FULFILL. inv REMOVE. unfold LocFun.add. s.
  condtac; [congr|]. auto.
Qed.

Lemma fulfill_step_to_local_write_step
      lc sc loc from to val releasedm released ord lc' sc' mem lo
      (FULFILL_STEP: fulfill_step lc sc loc from to val releasedm released ord lc' sc')
      (REL: released = TView.write_released (Local.tview lc) sc loc to releasedm ord)
      (ORD_MATCH: Ordering.mem_ord_match ord (lo loc))
      (IN_MEM: Memory.get loc to mem = Some (from, Message.concrete val released))
      (ORD: Ordering.le Ordering.strong_relaxed ord -> Memory.nonsynch_loc loc (Local.promises lc))
      (LT: Time.lt from to)
      (MSG_TO: Memory.message_to (Message.concrete val released) loc to):
  Local.write_step lc sc mem loc from to val releasedm released ord
                   lc' sc' mem
                   (Memory.op_kind_lower (Message.concrete val released)) lo
  /\ Memory.get loc to (Local.promises lc) = Some (from, Message.concrete val released).
Proof.
  inv FULFILL_STEP.
  exploit Memory.remove_get0; eauto. intros PROM_GET. ii; des.
  split; eauto.
  econs; eauto.
  econs; eauto.
  econs; eauto.
  eapply Memory.lower_exists_same; eauto.
  econs; eauto.
  eapply Memory.lower_exists_same; eauto.
  econs; eauto.
Qed.


From iris.program_logic Require Export weakestpre.
From iris.base_logic.lib Require Export invariants.
From iris.heap_lang Require Export lang.
From iris.proofmode Require Import tactics.
From iris.heap_lang Require Import proofmode notation.
From iris.algebra Require Import excl.
Set Default Proof Using "Type".

Definition spawn : val :=
  λ: "f",
    let: "c" := ref NONE in
    Fork ("c" <- SOME ("f" #())) ;; "c".
Definition join : val :=
  rec: "join" "c" :=
    match: !"c" with
      SOME "x" => "x"
    | NONE => "join" "c"
    end.

(** The CMRA & functor we need. *)
(* Not bundling heapG, as it may be shared with other users. *)
Class spawnG Σ := SpawnG { spawn_tokG :> inG Σ (exclR unitC) }.
Definition spawnΣ : gFunctors := #[GFunctor (exclR unitC)].

Instance subG_spawnΣ {Σ} : subG spawnΣ Σ → spawnG Σ.
Proof. solve_inG. Qed.

(** Now we come to the Iris part of the proof. *)
Section proof.
Context `{!heapG Σ, !spawnG Σ} (N : namespace).

Definition spawn_inv (γ : gname) (l : loc) (Ψ : val → iProp Σ) : iProp Σ :=
  (∃ lv, l ↦ lv ∗ (⌜lv = NONEV⌝ ∨
                   ∃ w, ⌜lv = SOMEV w⌝ ∗ (Ψ w ∨ own γ (Excl ()))))%I.

Definition join_handle (l : loc) (Ψ : val → iProp Σ) : iProp Σ :=
  (∃ γ, own γ (Excl ()) ∗ inv N (spawn_inv γ l Ψ))%I.

Global Instance spawn_inv_ne n γ l :
  Proper (pointwise_relation val (dist n) ==> dist n) (spawn_inv γ l).
Proof. solve_proper. Qed.
Global Instance join_handle_ne n l :
  Proper (pointwise_relation val (dist n) ==> dist n) (join_handle l).
Proof. solve_proper. Qed.

(** The main proofs. *)
Lemma spawn_spec (Ψ : val → iProp Σ) e (f : val) :
  IntoVal e f →
  {{{ WP f #() {{ Ψ }} }}} spawn e {{{ l, RET #l; join_handle l Ψ }}}.
Proof.
  iIntros (<- Φ) "Hf HΦ". rewrite /spawn /=.
  wp_let. wp_alloc l as "Hl". wp_let.
  iMod (own_alloc (Excl ())) as (γ) "Hγ"; first done.
  iMod (inv_alloc N _ (spawn_inv γ l Ψ) with "[Hl]") as "#?".
  { iNext. iExists NONEV. iFrame; eauto. }
  wp_apply wp_fork; simpl. iSplitR "Hf".
  - wp_seq. iApply "HΦ". rewrite /join_handle. eauto.
  - wp_bind (f _). iApply (wp_wand with "Hf"); iIntros (v) "Hv".
    iInv N as (v') "[Hl _]".
    wp_store. iSplitL; last done. iIntros "!> !>". iExists (SOMEV v). iFrame. eauto.
Qed.

Lemma join_spec (Ψ : val → iProp Σ) l :
  {{{ join_handle l Ψ }}} join #l {{{ v, RET v; Ψ v }}}.
Proof.
  iIntros (Φ) "H HΦ". iDestruct "H" as (γ) "[Hγ #?]".
  iLöb as "IH". wp_rec. wp_bind (! _)%E. iInv N as (v) "[Hl Hinv]".
  wp_load. iDestruct "Hinv" as "[%|Hinv]"; subst.
  - iModIntro. iSplitL "Hl"; [iNext; iExists _; iFrame; eauto|].
    wp_match. iApply ("IH" with "Hγ [HΦ]"). auto.
  - iDestruct "Hinv" as (v' ->) "[HΨ|Hγ']".
    + iModIntro. iSplitL "Hl Hγ"; [iNext; iExists _; iFrame; eauto|].
      wp_match. by iApply "HΦ".
    + iDestruct (own_valid_2 with "Hγ Hγ'") as %[].
Qed.
End proof.

Typeclasses Opaque join_handle.