Module fc_subst (wf : fc_wf_sig) (weak : fc_weak_sig) <: fc_subst_sig.
Export wf.
Export weak.
Set Bullet Behavior "Strict Subproofs".
Set Implicit Arguments.
(* --------------------------------------- *)
induction G0; auto; try done.
destruct a as [x s].
intros a b A c H H0.
destruct s; auto; try done.
case H0; try done.
+ move => h0;
simpl_env;
eapply AnnPropWff_weakening with (F:=nil); eauto; simpl_env;
inversion H; subst;
apply (IHG0 _ _ _ c); eauto.
+ destruct H0; subst.
inversion H0; subst.
inversion H; subst.
rewrite_env (nil ++ [(c, Co (Eq a b A))] ++ G0).
eapply AnnPropWff_weakening; eauto.
rewrite_env (nil ++ [(x, Co phi)] ++ G0).
eapply AnnPropWff_weakening; eauto.
simpl.
inversion H; subst.
apply (IHG0 _ _ _ c); auto.
Qed.
(* --------------------------------------- *)
(* Lemma co_subst_fresh : forall G phi a0 x s, AnnPropWff G phi -> AnnCtx ((x ~ s) ++ G) -> tm_subst_tm_constraint a0 x phi = phi. *)
(* --------------------------------------- *)
(* ------------------------------------------- *)
(* In the case of a binding term, prepare the environment in the goal for a use of the induction hypothesis *)
Ltac prepare_env :=
match goal with
[ |- context[ (?x' ~ (?S (?sub ?a1 ?x ?A))) ++ map (?tm_subst_tm_sort ?a1 ?x) ?F ++ ?G ] ] =>
rewrite -app_assoc;
replace (x' ~ (S (sub a1 x A)) ++  map (tm_subst_tm_sort a1 x) F) with
(map (tm_subst_tm_sort a1 x) (x' ~ S A ++ F)); eauto using map_app
end.
(* Find a binding for a prop in a well-formed context and invert it. *)
Ltac binds_PropWff_inversion :=
let wff := fresh in
match goal with
[ bind_c : binds ?c (Co (Eq ?a ?b ?A)) ?G0 |- _ ] =>
move: (@binds_to_AnnPropWff G0 _ _ _ _ ltac:(eauto with ctx_wff) bind_c) => wff;
inversion wff; subst
end.
(* --------------------------------------- *)
(* Convenience lemmas for working with substitution. *)
(* --------------------------------- *)
(* Convenience tactic for applying the coercion lemma above when there is an appropriate hypothesis in the context.  This tactic is useful when the goal is not in the right form for backwards reasoning (i.e. has metavariables in it, doesn't have the substitution at the top.)  *)
Ltac co_subst_hyp :=
match goal with
| [a0 : AnnTyping _ (a_Abs ?rho ?A1 ?b) _  |-  AnnTyping _ (a_Abs ?rho (_ ?A1) (_ ?b)) _ ] =>
eapply (first ann_co_substitution_mutual _ _ _ a0); eauto
| [a0 :  AnnTyping _ (a_Pi ?rho ?A1 ?B1) _ |- AnnTyping _ (a_Pi ?rho (_ ?A1) (_ ?B1)) _  ] =>
eapply (first ann_co_substitution_mutual _ _ _ a0); eauto
| [a0 : AnnTyping _ (a_CAbs ?phi ?B) _  |- AnnTyping _ (a_CAbs (_ ?phi) (_ ?B)) _ ] =>
eapply (first ann_co_substitution_mutual _ _ _ a0); eauto
| [a0 : AnnTyping _ (a_CPi ?phi ?B) _ |- AnnTyping _ (a_CPi (_ ?phi) (_ ?B)) _ ] =>
eapply (first ann_co_substitution_mutual _ _ _ a0); eauto
| [ a0 : AnnTyping _ (a_App ?a1 ?rho ?a2) _ |- AnnTyping _ (a_App (_ ?a1) ?rho (_ ?a2)) _ ] =>
eapply (first ann_co_substitution_mutual _ _ _ a0); eauto
| [ a0 : AnnTyping _ (a_CApp ?a1 ?g2) _ |- AnnTyping _ (a_CApp (_ ?a1) (_ ?g2)) _ ] =>
eapply (first ann_co_substitution_mutual _ _ _ a0); eauto
| [a0 : AnnDefEq _  _ _ (a_CPi ?phi1 ?B1) (a_CPi ?phi2 ?B2)  |-
AnnDefEq _ _ _ (a_CPi (_ ?phi1) _) (a_CPi (_ ?phi2) _) ] =>
eapply AnnDefEq_weaken_available;
eapply (fourth ann_co_substitution_mutual _ _ _ _ _ a0);
eauto
| [a0 : AnnPropWff _ (Eq ?a ?b ?A) |- AnnPropWff _ (Eq (_ ?a) (_ ?b) (_ ?A)) ] =>
eapply (second ann_co_substitution_mutual _ _ a0); eauto
| [ a0 : AnnTyping _ ?a _ |- AnnTyping _ (_ ?a) _ ] =>
eapply (first ann_co_substitution_mutual _ _ _ a0); eauto
| [a0 : AnnDefEq _ _ _ ?a _ |- AnnDefEq _ _ _ (_ ?a) _ ] =>
eapply AnnDefEq_weaken_available;
eapply (fourth ann_co_substitution_mutual _ _ _ _ _ a0);
eauto
| [ a0 : AnnDefEq _ _ ?g _ _ |- AnnDefEq _ _ (_ ?g) _ _ ] =>
eapply AnnDefEq_weaken_available;
eapply (fourth ann_co_substitution_mutual _ _ _ _ _ a0);
eauto
end.
(* Ltac expand sub_tm tm := match tm with | (a_Abs ?rho (_ ?A1) (_ ?b)) => replace (a_Abs rho (sub_tm A1) (sub_tm b)) with (sub_tm (a_Abs rho A1 b)); auto | (a_Pi ?rho (_ ?A1) (_ ?B1)) => replace (a_Pi rho (sub_tm A1) (sub_tm B1)) with (sub_tm (a_Pi rho A1 B1)); auto | (a_CAbs (?sc ?phi) (_ ?B)) => replace (a_CAbs (sc phi) (sub_tm B)) with (sub_tm (a_CAbs phi B)); auto | (a_CPi (?sc ?phi) (_ ?B)) => replace (a_CPi (sc phi) (sub_tm B)) with (sub_tm (a_CPi phi B)); auto  | a_Star => replace a_Star with (sub_tm a_Star); auto  | _ => idtac end.  Ltac expand_constraint sub_tm sub_constraint constraint := match constraint with | (Eq (_ _ _ ?a) (_ _ _  ?b) (_ _ _ ?A)) => replace (Eq (sub_tm a) (sub_tm b) (sub_tm A)) with (sub_constraint (Eq a b A)); auto | _ => idtac end.  Ltac un_co_subst_co := match goal with | [ |- context [co_subst_co_tm ?g ?c _] ] => match goal with | [ |- AnnTyping _ ?a ?A ] => expand (co_subst_co_tm g c) a; expand (co_subst_co_tm g c) A | [ |- AnnDefEq _ _ ?a ?b ] => expand (co_subst_co_tm g c) a; expand (co_subst_co_tm g c) b | [ |- AnnPropWff ?phi ] => expand_constraint (co_subst_co_tm g c) (co_subst_co_constraint g c) phi end end. *)
(* (* Pull a substitution out to prepare for an application of the substution lemma above *)
Ltac un_co_subst_co_tm' C :=
match goal with
| [ |- context [co_subst_co_tm ?g ?c ?a] ] =>
replace C with (co_subst_co_tm g c C); auto
end.
(* This doesn't work. *)
Ltac un_co_subst_co_tm :=
match goal with
| [ |- context [ a_Pi ?rho (co_subst_co_tm ?g ?c ?A1) (co_subst_co_tm ?g ?c ?B1)] ] =>
replace (a_Pi rho (co_subst_co_tm g c A1) (co_subst_co_tm g c B1))
with (co_subst_co_tm (a_Pi rho A1 B1)); auto
| [ |- context[ (Eq (co_subst_co_tm ?g ?c ?a) (co_subst_co_tm ?g ?c ?b)
(co_subst_co_tm ?g ?c ?A)) ] ] =>
replace (Eq (co_subst_co_tm g c a) (co_subst_co_tm g c b)
(co_subst_co_tm g c A)) with
(co_subst_co_constraint g c (Eq a b A)); auto
| [ |- AnnTyping _ _ a_Star ] => un_co_subst_co_tm' a_Star
| [ |- AnnTyping _ a_Star _ ] => un_co_subst_co_tm' a_Star
| [ |- AnnDefEq _ _ a_Star _ _ ] => un_co_subst_co_tm' a_Star
| [ |- AnnDefEq _ _ _ a_Star _ ] => un_co_subst_co_tm' a_Star                                               | [ |- AnnDefEq _ _ _ _ a_Star ] => un_co_subst_co_tm' a_Star
| [ |- AnnTyping (a_Const ?T) _ ] => un_co_subst_co_tm' (a_Const T)
| [ |- AnnTyping _ (a_Const ?T) ] => un_co_subst_co_tm' (a_Const T)
| [ |- AnnTyping (a_Fam ?T) _ ] => un_co_subst_co_tm' (a_Fam T)
| [ |- AnnTyping _ (a_Fam ?T) ] => un_co_subst_co_tm' (a_Fam T)
end.
*)
(* --------------------------------------------------------------------- *)
(* swapping lemmas ---> changing the name that is used to opened terms *)
Ltac rename_tm_Typing x0 K2 :=
let M1 := fresh in
let K1 := fresh in
match goal with
[ H0 : AnnTyping ([(?x, Tm ?A)] ++ ?G) (open_tm_wrt_tm ?B (a_Var_f ?x)) ?C |- _]
=> assert (AC : AnnCtx ([(x, Tm A)] ++ G)); eauto with ctx_wff;
inversion AC; subst;
assert (TV : AnnTyping ([(x0,Tm A)] ++ G) (a_Var_f x0) A); eauto;
assert (CTX : AnnCtx ([(x,Tm A)] ++ [(x0, Tm A)] ++ G));
[ match goal with
[ H7 : AnnTyping G A a_Star |- _] =>
econstructor; auto;
pose M1 := (AnnTyping_weakening H7 [(x0,Tm A)] nil G);
simpl_env in M1; eapply M1; eauto end |
pose K1 := AnnTyping_weakening H0 [(x0,Tm A)] [(x, Tm A)] G eq_refl CTX;
clearbody K1;
pose K2 := (first ann_tm_substitution_mutual) _ _ _ K1 _ _ _ TV nil x eq_refl;
clearbody K2; simpl_env in K2;
repeat rewrite tm_subst_tm_tm_open_tm_wrt_tm in K2; auto;
rewrite tm_subst_tm_tm_var in K2;
rewrite tm_subst_tm_tm_fresh_eq in K2]
end.

Lemma AnnTyping_co_swap : forall c c0 phi G a A,
c `notin` fv_co_co_tm A ->
c `notin` fv_co_co_tm a ->
c0 `notin` dom G \u {{ c }} ->
AnnTyping ([(c, Co phi)] ++ G) (open_tm_wrt_co a (g_Var_f c))
(open_tm_wrt_co A (g_Var_f c)) ->
AnnTyping ([(c0, Co phi)] ++ G) (open_tm_wrt_co a (g_Var_f c0))
(open_tm_wrt_co A (g_Var_f c0)).