Set Bullet Behavior "Strict Subproofs".
Set Implicit Arguments.
Require Export FcEtt.tactics.
Require Export FcEtt.imports.
Require Export FcEtt.ett_inf.
Require Export FcEtt.ett_ott.
Require Export FcEtt.ett_ind.
Require Export FcEtt.ext_context_fv.
Require Export FcEtt.toplevel.
Require Export FcEtt.ett_value.
(* ------------------------------------------ *)
(* Synatactic properties about parallel reduction. (Excluding confluence.) *)
(* ------------------------------------------ *)
(* TODO: move these definitions to the OTT file. *)
Inductive multipar S D ( a : tm) : tm -> Prop :=
| mp_refl : multipar S D a a
| mp_step : forall b c, Par S D a b -> multipar S D b c -> multipar S D a c.
Hint Constructors multipar.
(* Inductive consistent : tm -> tm -> Prop := | consistent_a_Star   : consistent a_Star a_Star | consistent_a_Pi     : forall rho A1 B1 A2 B2, lc_tm A1 -> lc_tm (a_Pi rho A1 B1) -> lc_tm A2 -> lc_tm (a_Pi rho A2 B2) -> consistent (a_Pi rho A1 B1) (a_Pi rho A2 B2) | consistent_a_CPi    : forall phi1 A1 phi2 A2, lc_constraint phi1 -> lc_tm (a_CPi phi1 A1) -> lc_constraint phi2 -> lc_tm (a_CPi phi2 A2) -> consistent (a_CPi phi1 A1) (a_CPi phi2 A2) | consistent_Path     : forall T p1 p2, Path T p1 -> Path T p2 -> consistent p1 p2 | consistent_a_Const  : forall T, consistent (a_Const T)(a_Const T) | consistent_a_App    : forall p1 p2 b1 b2 rho, lc_tm b1 -> lc_tm b2 -> consistent p1 p2 -> consistent (a_App p1 rho b1) (a_App p2 rho b2) | consistent_a_CApp    : forall p1 p2 b1 b2, lc_co b1 -> lc_co b2 -> consistent p1 p2 -> consistent (a_CApp p1 b1) (a_CApp p2 b2) | consistent_a_Step_R : forall a b, lc_tm a -> not (value_type b) -> consistent a b | consistent_a_Step_L : forall a b, lc_tm a -> not (value_type b) -> consistent b a. Hint Constructors consistent. *)
(* Inductive erased_tm : tm -> Prop := | erased_a_Bullet : (erased_tm a_Bullet) | erased_a_Star : (erased_tm a_Star) | erased_a_Var_f : forall (x:tmvar), (erased_tm (a_Var_f x)) | erased_a_Abs : forall L rho (b:tm), ( forall x , x `notin` L -> erased_tm  ( open_tm_wrt_tm b (a_Var_f x) )  )  -> (erased_tm (a_UAbs rho b)) | erased_a_App : forall rho (a b:tm), (erased_tm a) -> (erased_tm b) -> (erased_tm (a_App a rho b)) | erased_a_Pi : forall L rho (A B:tm), (erased_tm A) -> ( forall x , x `notin` L -> erased_tm  ( open_tm_wrt_tm B (a_Var_f x) )  )  -> (erased_tm (a_Pi rho A B)) | erased_a_CPi : forall L (A A1 A2: tm) (B:tm), (erased_tm A1) ->  (erased_tm A2) -> (erased_tm A) -> ( forall c , c `notin` L -> erased_tm  ( open_tm_wrt_co B (g_Var_f c) )  )  -> (erased_tm (a_CPi (Eq A1 A2 A) B)) | erased_a_CAbs : forall L (A A1 A2:tm) (b:tm), (forall c , c `notin` L -> erased_tm  ( open_tm_wrt_co b (g_Var_f c) )  )  -> (erased_tm (a_UCAbs b)) | erased_a_CApp : forall (a:tm), (erased_tm a) -> (erased_tm (a_CApp a g_Triv)) | erased_a_Const : forall T, erased_tm (a_Const T) | erased_a_Fam : forall F, erased_tm (a_Fam F) .  Hint Constructors erased_tm. *)
(* NOTE: we have a database 'erased' for proving that terms are erased. *)
(* Tactics concerning erased terms. *)
Ltac erased_pick_fresh x :=
match goal with
[ |- erased_tm ?s ] =>
let v := match s with
| a_UAbs _ _  => erased_a_Abs
| a_Pi _ _ _  => erased_a_Pi
| a_CPi _ _   => erased_a_CPi
| a_UCAbs _   => erased_a_CAbs
end
in pick fresh x and apply v
end.
Ltac erased_inversion :=
repeat match goal with
| [H : erased_tm (a_UAbs _ _)|- _ ] =>
inversion H; subst; clear H
| [H : erased_tm (a_App _ _ _)|- _ ] =>
inversion H; subst; clear H
| [H : erased_tm (a_Pi _ _ _)|- _ ] =>
inversion H; subst; clear H
| [H : erased_tm (a_CPi _ _)|- _ ] =>
inversion H; subst; clear H
| [H : erased_tm (a_UCAbs _ ) |- _ ] =>
inversion H; subst; clear H
| [H : erased_tm (a_CApp _ _)|- _ ] =>
inversion H; subst; clear H
end.
Ltac erased_case :=
let x := fresh in
let h0 := fresh in
erased_pick_fresh x; eauto using lc_erase;
match goal with
[ H : forall x, erased_tm (erase (open_tm_wrt_tm ?b (a_Var_f x))) |- _ ] =>
move: (H x) => h0; rewrite <- open_tm_erase_tm in h0; eauto
| [ H : ∀ c, erased_tm (erase (open_tm_wrt_co ?b (g_Var_f c))) |- _ ] =>
move: (H x) => h0; rewrite <- open_co_erase_tm2 with (g := (g_Var_f x)) in h0; auto
end.
(*  Lemma erased_tm_erase_mutual : (forall a, lc_tm a -> erased_tm (erase a)) /\ (forall a, lc_brs a -> True) /\ (forall a, lc_co a -> True) /\ (forall phi, lc_constraint phi -> forall a b A, phi = (Eq a b A) -> erased_tm (erase a) /\ erased_tm (erase b) /\ erased_tm (erase A)).   (* Lemma erased_tm_erase : forall a, lc_tm a -> erased_tm (erase a).  Hint Resolve erased_tm_erase : erased. *)
Inductive erased_sort : sort -> Prop :=
| erased_Tm : forall a, erased_tm a -> erased_sort (Tm a)
| erased_Co : forall a b A, erased_tm a -> erased_tm b -> erased_tm A -> erased_sort (Co (Eq a b A)).
(* Check Forall_forall *)
Definition erased_context : context -> Prop :=
Forall (fun p => match p with (a,s) => erased_sort s end).
Definition joins S D a b := exists c, erased_context S /\ erased_tm a /\ erased_tm b /\
multipar S D a c /\ multipar S D b c.
intros; induction H; auto.
Qed.
Hint Resolve erased_lc : lc.
Hint Resolve subst_tm_erased subst_co_erased : erased.
intros.  induction H; auto. all: lc_solve.
Qed.
(* FIXME: find a good place for this tactic. *)
(* cannot move this to ett_ind.v because need Toplevel_lc ??? *)
Ltac lc_toplevel_inversion :=
match goal with
| [ b : binds ?F _ toplevel |- _ ] =>
apply Toplevel_lc in b; inversion b; auto
end.
Hint Resolve Par_lc1 Par_lc2 : lc.
Hint Resolve Typing_erased : erased.
Hint Resolve toplevel_erased1 toplevel_erased2 : erased.
(* Introduce a hypothesis about an erased opened term. *)
Ltac erased_body x Ea :=
match goal with
| [ H4 : ∀ x : atom, x `notin` ?L0 → erased_tm (open_tm_wrt_tm ?a (a_Var_f x))
|- _ ] =>
move: (H4 x ltac:(auto)) => Ea; clear H4
| [ H4 : ∀ x : atom, x `notin` ?L0 → erased_tm (open_tm_wrt_co ?a (g_Var_f x))
|- _ ] =>
move: (H4 x ltac:(auto)) => Ea; clear H4
end.
(* Move this to ett_ind? *)
Ltac eta_eq y EQ :=
match goal with
| [ H : ∀ x : atom, x `notin` ?L → open_tm_wrt_tm ?a (a_Var_f x) =
a_App ?b ?rho _ |- _ ] =>
move: (H y ltac:(auto)) =>  EQ
end.
Hint Resolve Par_erased_tm : erased.
(* ------------------------------------------------------------- *)
Hint Resolve erased_tm_open_tm_wrt_tm : erased.

Lemma multipar_Pi_B_proj: ∀ (G : context) D rho (A B A' B' : tm),
multipar G D (a_Pi rho A B) (a_Pi rho A' B')
→ (exists L, forall x, x `notin` L -> multipar G D (open_tm_wrt_tm B (a_Var_f x)) (open_tm_wrt_tm B' (a_Var_f x))).