Module red := ext_red invert.
Export red.
Set Implicit Arguments.
Set Bullet Behavior "Strict Subproofs".
Definition Good (G : context) (D : available_props):=
erased_context G /\
forall c1 A B1 T1,
binds c1 (Co (Eq A B1 T1)) G
-> c1 `in` D
-> exists C, Par G D A C /\ Par G D B1 C.
(* ---------------------------------------- *)
(* Lemma Par_Abs_inversion_Irrel_2: forall G D a b, Par G D (a_UAbs Irrel a) b -> (exists a', b = (a_UAbs Irrel a') /\ Par G D (open_tm_wrt_tm a (a_Bullet)) (open_tm_wrt_tm a' (a_Bullet))) \/ (exists a', Par G D a' b /\ (forall x, x `notin`  fv_tm_tm_tm a -> open_tm_wrt_tm a (a_Var_f x) = a_App a' Irrel a_Bullet)).   Lemma Par_CAbs_inversion : forall G D a b, Par G D (a_UCAbs a) b -> (exists a', b = (a_UCAbs a') /\ forall c, c `notin` fv_co_co_tm a \u fv_co_co_tm a' -> Par G D (open_tm_wrt_co a (g_Var_f c)) (open_tm_wrt_co a' (g_Var_f c))) \/ (exists a', Par G D a' b /\ (forall c, c `notin`  fv_co_co_tm a -> open_tm_wrt_co a (g_Var_f c) = a_CApp a' g_Triv)).   Lemma copen2 : forall c (b: co) S D a a', lc_co b -> c `notin` fv_co_co_tm a' \u fv_co_co_tm a -> Par S D (open_tm_wrt_co a (g_Var_f c)) (open_tm_wrt_co a' (g_Var_f c)) -> Par S D (open_tm_wrt_co a b) (open_tm_wrt_co a' b).  (* -------------------------------------------------------------------------------- *)
Ltac try_refl :=
try match goal with
| [ P2 : Par _ _ _ ?b |- _ ] =>
exists b; assert (lc_tm b); try eapply Par_lc2; eauto; try split; eauto; fail
end.
(* Ltac invert_syntactic_equality := match goal with | [ H : a_UAbs _ _ = a_UAbs _ _ |- _ ] => inversion H; subst; clear H | [ H : a_Pi _ _ _ = a_Pi _ _ _ |- _ ] => inversion H; subst; clear H | [ H : a_UCAbs _ = a_UCAbs _ |- _ ] => inversion H; subst; clear H | [ H : a_App _ _ _ = _ _ _ |- _ ] => inversion H; subst; clear H | [ H : a_CApp _ _  = a_CApp _ _ |- _ ] => inversion H; subst; clear H | [ H : a_Fam _ = a_Fam _ |- _ ] => inversion H; subst; clear H | [ H : a_CPi _ _ = a_CPi _ _ |- _ ] => inversion H; subst; clear H end. *)
Ltac invert_equality :=
match goal with
| [ H : _ = _ |- _ ] =>
inversion H
end.
Ltac try_refl_left :=
try match goal with
| [ P2 : Par _ _ ?b ?b |- exists cc:tm, Par ?S ?D ?b cc /\ Par ?S ?D ?a2 cc ] =>
exists a2; assert (lc_tm a2); try eapply Par_lc2; eauto; try split; eauto; fail
end.
Ltac try_refl_right :=
try match goal with
| [ P2 : Par _ _ ?b ?b |- exists cc:tm, Par ?S ?D ?a2 cc /\ Par ?S ?D ?b cc ] =>
exists a2; assert (lc_tm a2); try eapply Par_lc2; eauto; try split; eauto; fail
end.
Ltac invert_erased :=
match goal with
| [ H : erased_tm ?a |- _ ] => inversion H; subst; clear H
end.
(* Find prove that the result of Par is erased, and then invert that *)
Ltac invert_erased_tm b :=
let h0 := fresh in
match goal with
[ h : Par ?G ?D ?a b, h1: erased_tm ?a |- _ ] =>
assert (h0 : erased_tm b);
[ eapply (Par_erased_tm h); eauto | inversion h0; subst]
end.
(*    If we know that (a ^ x) == (App b rho x), replace (a ^ b0) with (App b rho b0) The tactic only succeeds if there is only 1 equality in the context. *)
Ltac eta_expand x :=
let h1 := fresh in
match goal with
| [ H18 : ∀ x : atom,
x `notin` ?L0
→ open_tm_wrt_tm ?a (a_Var_f x) = a_App ?b0 ?rho (a_Var_f x)
|- _ ] =>
pick fresh x for (L0 \u  fv_tm_tm_tm a \u fv_tm_tm_tm b0);
move: (H18 x ltac:(auto)) => h1; clear H18;
rewrite (@tm_subst_tm_tm_intro x a); auto; rewrite h1;
simpl; destruct (@eq_dec tmvar _ x x); try done;
rewrite tm_subst_tm_tm_fresh_eq; auto
| [ H18 : ∀ x : atom,
x `notin` ?L0
→ open_tm_wrt_tm ?a (a_Var_f x) = a_App ?b0 ?rho a_Bullet
|- _ ] =>
pick fresh x for (L0 \u  fv_tm_tm_tm a \u fv_tm_tm_tm b0);
move: (H18 x ltac:(auto)) => h1; clear H18;
rewrite (@tm_subst_tm_tm_intro x a); auto; rewrite h1;
simpl; destruct (@eq_dec tmvar _ x x); try done;
rewrite tm_subst_tm_tm_fresh_eq; auto
| [ H18 : ∀ x : atom,
x `notin` ?L0
→ open_tm_wrt_co ?a (g_Var_f x) = a_CApp ?b0 g_Triv
|- _ ] =>
pick fresh x for (L0 \u  fv_co_co_tm a \u fv_co_co_tm b0);
move: (H18 x ltac:(auto)) => h1; clear H18;
rewrite (@co_subst_co_tm_intro x a); auto; rewrite h1;
simpl; destruct (@eq_dec tmvar _ x x); try done;
rewrite co_subst_co_tm_fresh_eq; auto
end.
(* Rewrite a goal of the form ... (a'0 ^ b'0) ... To ... (b . b'0) ... and try to solve it, give eta-assn Y2 *)
Ltac eta_case a'0 Y2 :=
let x:= fresh in
pick fresh x;
rewrite (tm_subst_tm_tm_intro x a'0); auto;
rewrite Y2; auto; simpl;
rewrite (tm_subst_tm_tm_fresh_eq); auto;
destruct eq_dec; try done;
eauto; clear x.
Ltac invert_lc :=
match goal with
| [ H : lc_tm ?a |- _ ] => inversion H; subst; clear H
end.
Ltac use_size_induction a ac Par1 Par2 :=
match goal with
| [   IH : forall y: nat, ?T,
H2 : Good ?G ?D,
H3 : erased_tm a,
H : Par ?G ?D a ?b0,
H4 : Par ?G ?D a ?b1 |- _ ] =>
move: (@IH (size_tm a) ltac:(omega) a ltac:(auto) _ _ _ H2 H3 H _ H4) => [ ac [Par1 Par2]]
end.
Ltac use_size_induction_open a0 x ac Par1 Par2 :=
let h0 := fresh in
let h1 := fresh in
let h2 := fresh in
let EQ1 := fresh in
let EQ2 := fresh in
match goal with
| [  H : ∀ x : atom,
x `notin` ?L
→ Par ?S ?D (?open_tm_wrt_tm a0 (?a_Var_f x)) ?b,
H4: ∀ x : atom,
x `notin` ?L0
→ Par ?S ?D (?open_tm_wrt_tm a0 (?a_Var_f x)) ?c,
H1 : ∀ x : atom, x `notin` ?L1 →
erased_tm (?open_tm_wrt_tm a0 (?a_Var_f x)) |- _ ] =>
move: (H x ltac:(auto)) => h0; clear H;
move: (H4 x ltac:(auto)) => h1; clear H4;
move: (H1 x ltac:(auto)) => h2; clear H1;
move: (size_tm_open_tm_wrt_tm_var a0 x) => EQ1;
move: (size_tm_open_tm_wrt_co_var a0 x) => EQ2;
use_size_induction (open_tm_wrt_tm a0 (a_Var_f x)) ac Par1 Par2;
clear h0; clear h1; clear h2; clear EQ1; clear EQ2
end.
(* Ltac use_induction a ac Par1 Par2 := match goal with | [ IHPar1 : Good ?G ?D -> erased_tm a → ∀ a2 : tm, Par ?G ?D ?a a2 → ?T , H2 : Good ?G ?D, H3 : erased_tm a, H4 : Par ?G ?D a ?b |- _ ] => destruct (IHPar1 H2 H3 _ H4) as [ac [Par1 Par2]] end.  Ltac use_induction_on a b ac Par1 Par2 := match goal with | [ IHPar1 : Good ?G ?D -> erased_tm a → ∀ a2 : tm, Par ?G ?D ?a a2 → ?T , H2 : Good ?G ?D, H3 : erased_tm a, H4 : Par ?G ?D a b |- _ ] => destruct (IHPar1 H2 H3 _ H4) as [ac [Par1 Par2]] end. *)
Ltac par_erased_open x J Par4 :=
let K := fresh in
let KK := fresh in
let h0 := fresh in
match goal with
| [H13 : ∀ x : atom, x `notin` ?L →
Par ?G ?D (open_tm_wrt_tm ?a (a_Var_f x)) ?b,
H4 : ∀ x : atom, x `notin` ?L1 → erased_tm  (open_tm_wrt_tm ?a (a_Var_f x))
|- _ ] =>
have: x `notin` L; auto => h0;
pose K:= H13 x h0; clearbody K; clear h0;
have: x `notin` L1; auto => h0;
pose KK := H4 x h0; clearbody KK;
pose J := subst3 x Par4 KK K;
clearbody J;
repeat rewrite tm_subst_tm_tm_open_tm_wrt_tm in J; [auto;
simpl in J;
destruct eq_dec; try congruence;
repeat rewrite tm_subst_tm_tm_fresh_eq in J; auto
| try apply (Par_lc2 Par4); auto
| apply (Par_lc1 Par4); auto]
end.
Ltac finish_open_co a'0 :=
let K := fresh in
let J := fresh in
let h0 := fresh in
match goal with
| H12 : forall c, c `notin` ?L -> Par ?G ?D (open_tm_wrt_co a'0 (g_Var_f c)) (open_tm_wrt_co ?b (g_Var_f c)) |- _ =>
pick_fresh c;
have: c `notin` L; auto => h0;
pose K := H12 c h0; clearbody K;
pose J := subst4 c lc_g_Triv K;
clearbody J;
repeat rewrite co_subst_co_tm_open_tm_wrt_co in J; eauto;
simpl in J;
destruct eq_dec; try congruence;
repeat rewrite co_subst_co_tm_fresh_eq in J; eauto with lc
end.
(* Extra tactic? There's the same one above confluenze size.  Ltac use_size_induction b ac Par1 Par2 := match goal with | [   IH : forall y: nat, ?T, H2 : Good S D, H3 : erased_tm b, H : Par S D b ?b0, H4 : Par S D b ?b1 |- _ ] => move: (@IH (size_tm b) ltac:(omega) b ltac:(auto) _ _ _ H2 H3 H _ H4) => [ ac [Par1 Par2]] end. *)
(* ---------------------------------------------------------------------- *)
(* OLD Inductive Path_consistent : const -> tm -> tm -> Prop := PC_Const : forall T, Path_consistent T (a_Const T) (a_Const T) | PC_App   : forall T a1 rho a2 b1 b2, erased_tm a2 -> erased_tm b2 -> Path_consistent T a1 b1 -> Path_consistent T (a_App a1 rho a2) (a_App b1 rho b2) | PC_CApp  : forall T a1 b1, Path_consistent T a1 b1 -> Path_consistent T (a_CApp a1 g_Triv) (a_CApp b1 g_Triv). Hint Constructors Path_consistent. *)
Inductive Path_consistent : const -> tm -> tm -> Prop :=
PC_Const : forall T, Path_consistent T (a_Const T) (a_Const T)
| PC_App   : forall T a1 a2 b1 b2,
erased_tm a2 -> erased_tm b2 ->
Path_consistent T a1 b1 ->
Path_consistent T (a_App a1 Rel a2) (a_App b1 Rel b2)
| PC_AppIrrel : forall T a1 b1,
Path_consistent T a1 b1 ->
Path_consistent T (a_App a1 Irrel a_Bullet) (a_App b1 Irrel a_Bullet)
| PC_CApp  : forall T a1 b1,
Path_consistent T a1 b1 ->
Path_consistent T (a_CApp a1 g_Triv) (a_CApp b1 g_Triv).
Hint Constructors Path_consistent.
Ltac binds_notbinds :=
match goal with
[ H0 : binds ?c (Ax ?T ?a) toplevel,
H5 : forall (c : atom) a, not (binds c (Ax ?T a) an_toplevel) |- _  ] =>
unfold not in H5; unfold toplevel in H0; unfold erase_sig in H0;
apply binds_map_3 in H0; destruct H0 as (s' & EQ & B);
destruct s'; simpl in EQ; inversion EQ; subst;
apply H5 in B; contradiction
end.
intros S D rho A B H. induction H. intros. subst. exists A1, A2. auto.
intros. subst.
inversion H; subst; destruct (IHmultipar _ _ eq_refl) as [B1 [B2 EQ]]; auto;
exists B1, B2; auto.
Qed.
(* --------------------------------------------------- *)
Definition decide_Path : forall a, lc_tm a -> (exists T, Path T a) \/ (forall T, not (Path T a)).
(* --------------------------------------------------- *)
(* Proof that joinability implies consistency. *)
Ltac step_left := apply consistent_a_Step_R; [auto |intro N; inversion N; inversion H0]; fail.
Ltac step_right := apply consistent_a_Step_L; [auto | intro N; inversion N; inversion H0]; fail.
(* look for a multipar involvong a head form and apply the appropriate lemma for that head form. Note: for paths, the lemma has already been applied so we only need to look for a hypothesis about path consistency. *)
Ltac multipar_step SIDE EQ :=
match goal with
| [ SIDE : multipar _ _ a_Star _ |- _ ] =>
apply multipar_Star in SIDE; auto; rename SIDE into EQ
| [ SIDE : multipar _ _ (a_Pi _ _ _) _ |- _ ] =>
destruct (multipar_Pi SIDE eq_refl) as [b1' [b2' EQ]]
| [ SIDE : multipar _ _ (a_CPi ?phi _) _ |- _ ] =>
try (destruct phi); destruct (multipar_CPi SIDE eq_refl)
as (B1' & B2' & C1' & C2' &  EQ)
| [ SIDE : multipar _ _ (a_Const ?T) _ |- _ ] =>
apply multipar_Const in SIDE; auto; rename SIDE into EQ
| [ SIDE : Path_consistent _ _ _ |- _ ] =>
rename SIDE into EQ
end.
(*  a  -> b -->* c      d - by confluence |     |      |      e - by induction v     v      v a2 -> d -->* e *)
(*  a -->  b -->* c    d - by prior lemma |      |      |    e - by induction. v      v      v *      *      * a2 --> d -->* e  *)
(* a   b   c \ / \ / ab  bc \ / d *)
Definition extends (G G2 : context) := exists G1, G = G1 ++ G2.
induction 2; eauto.
apply IHmultipar.
eapply Par_lc2; apply H0.
Qed.
Hint Resolve multipar_context_independent : DB.
Hint Resolve Good_NoAssn.
Hint Resolve multipar_context_independent.
(* Lemma Par_iapp : forall G D a c y L, y `notin` fv_tm_tm_tm a \u L -> (forall x, x `notin` L -> RhoCheck Irrel x (open_tm_wrt_tm a (a_Var_f x))) -> Par G D (open_tm_wrt_tm a a_Bullet) c -> Par G D (a_UAbs Irrel a) (a_UAbs Irrel (close_tm_wrt_tm y c)). *)
(* ------------------------------------------------------- *)
Definition irrelevant G D (a : tm) :=
(forall x A, binds x (Tm A) G -> x `notin` fv_tm a) /\ Good G D.
intros. inversion H.
auto.
Qed.
(* Ltac impossible_defeq A B := match goal with | h0 : DefEq G A B a_Star => apply consistent_defeq in h0; eauto; apply join_consistent in h0; *)
Ltac impossible_Path :=
match goal with
[H : Path ?T (a_Pi _ _ _) |- _] => inversion H
| [H : Path ?T a_Star |- _] => inversion H
| [H : Path ?T (a_CPi _ _) |- _] => inversion H
end.
(* When we have a defeq in the context between two value types, show that it can't happen. *)
Ltac impossible_defeq :=
let h0 := fresh in
let VT := fresh in
let VT2 := fresh in
match goal with
| [ H : DefEq ?G (dom ?G) ?B ?A ?C |- _ ] =>
pose h0:= H; clearbody h0;
apply consistent_defeq in h0; eauto;
[apply join_consistent in h0;
destruct (DefEq_lc H) as (l0 & l1 & l2); inversion l0; inversion l1; subst;
have VT: value_type A; eauto;
have VT2 : value_type B; eauto;
inversion h0; subst; try impossible_Path;
eauto; try done | eapply irrelevant_Good; eauto]
end.

Lemma canonical_forms_Star : forall G a, irrelevant G (dom G) a ->
Typing G a a_Star -> Value a -> value_type a.