Set Bullet Behavior "Strict Subproofs".
Set Implicit Arguments.
Module fc_get (wf : fc_wf_sig) (weak : fc_weak_sig) (subst : fc_subst_sig) (unique: fc_unique_sig).
Module invert := fc_invert wf weak subst.
(* -------------------------------------------------------------------------------------- *)
(* This function looks at an annotated term and returns its type. *)
Fixpoint get_tpg_n (n : nat) (G : context) (a : tm) { struct n } : tm :=
match n with
| 0 => a_Star
| S m =>
match a with
| a_Star => a_Star
| a_Var_f x =>
match binds_lookup _ x G with
| inl (exist (Tm A) _) => A
| _ => a_Star
end
| a_Pi  rho A B => a_Star
| a_Abs rho A a =>
let (x,_) := atom_fresh (dom G) in
a_Pi rho A (close_tm_wrt_tm x (get_tpg_n m ((x,Tm A)::G) (open_tm_wrt_tm a (a_Var_f x))))
| a_App a1 rho a2 =>
match get_tpg_n m G a1 with
| a_Pi rho A B => open_tm_wrt_tm B a2
| _ => a_Star
end
| a_Conv a g => let (_,b) := get_deq_n m G g in b
| a_CPi phi B => a_Star
| a_CAbs phi a => let (x,_) := atom_fresh (dom G) in
a_CPi phi (close_tm_wrt_co x (get_tpg_n m ((x,Co phi)::G) (open_tm_wrt_co a (g_Var_f x))))
| a_Fam F =>
match binds_lookup _ F an_toplevel with
| inl (exist (Ax a A) _) => A
| _ => a_Star
end
| a_CApp a1 g2 =>
match get_tpg_n m G a1 with
| a_CPi phi B => open_tm_wrt_co B g2
| _ => a_Star
end
| a_Const T =>
match binds_lookup _ T an_toplevel with
| inl (exist (Cs A) _) => A
| _ => a_Star
end
| _ => a_Star
end
end
with
get_iso_n (n : nat) (G : context) (g : co) : (constraint * constraint) :=
match n with
| 0 => (Eq a_Star a_Star a_Star,Eq a_Star a_Star a_Star)
| S m =>
match g with
| (g_EqCong g1 A g2) =>
let (A1, A2) := get_deq_n m G g1 in
let (B1, B2) := get_deq_n m G g2 in
(Eq A1 B1 A, Eq A2 B2 A)
| g_CPiFst g =>
let (T1,T2) := get_deq_n m G g in
match (T1, T2) with
| (a_CPi phi1 A2, a_CPi phi2 B2) => (phi1, phi2)
| _ => (Eq a_Star a_Star a_Star,Eq a_Star a_Star a_Star)
end
| g_Sym g =>
let (phi2, phi1) := get_iso_n m G g in
(phi1, phi2)
| g_IsoConv (Eq a1 a2 A) (Eq a1' a2' B) g =>
(Eq a1 a2 A, Eq a1' a2' B)
| _ => (Eq a_Star a_Star a_Star,Eq a_Star a_Star a_Star)
end
end
with
get_deq_n (n : nat) (G : context) (g : co) : (tm * tm) :=
match n with
| 0 => (a_Star, a_Star)
| S m =>
match g with
| g_Var_f c => match binds_lookup _ c G with
| inl (exist (Co (Eq a b A)) _) => (a,b)
| _ => (a_Star, a_Star)
end
| g_Refl a => (a,a)
| g_Refl2 a b g => (a,b)
| g_Beta a b => (a,b)
| g_Sym g => let (a,b) := get_deq_n m G g in
(b,a)
| g_Trans g1 g2 =>
let (a,c1) := get_deq_n m G g1 in
let (c2, b) := get_deq_n m G g2 in
(a,b)
| g_PiCong rho g1 g2 =>
let (x,_) := atom_fresh (dom G) in
let (A1,A2) := get_deq_n m G g1 in
let (B1,B2) := get_deq_n m ([(x, Tm A1)] ++ G) (open_co_wrt_tm g2 (a_Var_f x)) in
let B3 := tm_subst_tm_tm (a_Conv (a_Var_f x) (g_Sym g1)) x B2 in
(a_Pi rho A1 (close_tm_wrt_tm x B1), a_Pi rho A2 (close_tm_wrt_tm x B3))
| g_AbsCong rho g1 g2 =>
let (x,_) := atom_fresh (dom G) in
let (A1,A2) := get_deq_n m G g1 in
let (b1,b2) := get_deq_n m ([(x,Tm A1)] ++ G) (open_co_wrt_tm g2 (a_Var_f x)) in
let b3 := tm_subst_tm_tm (a_Conv (a_Var_f x) (g_Sym g1)) x b2 in
(a_Abs rho A1 (close_tm_wrt_tm x b1), a_Abs rho A2 (close_tm_wrt_tm x b3))
| g_AppCong g1 rho g2 =>
let (a1, b1) := get_deq_n m G g1 in
let (a2, b2) := get_deq_n m G g2 in
(a_App a1 rho a2, a_App b1 rho b2)
| g_PiFst g =>
let (a,b) := get_deq_n m G g in
match (a,b) with
| (a_Pi rho1 A1 B1, a_Pi rho2 A2 B2) => (A1, A2)
| (_,_) => (a_Star, a_Star)
end
| g_PiSnd g1 g2 =>
let (T1,T2) := get_deq_n m G g1 in
let (a1,a2) := get_deq_n m G g2 in
match (T1,T2) with
| (a_Pi rho1 A1 B1, a_Pi rho2 A2 B2) =>
(open_tm_wrt_tm B1 a1, open_tm_wrt_tm B2 a2)
| (_,_) => (a_Star, a_Star)
end
| g_CPiCong g1 g3 =>
let (phi1,phi2) := get_iso_n m G g1 in
let (x,_) := atom_fresh (dom G) in
let (B1,B2) := get_deq_n m ([(x,Co phi1)] ++ G)
(open_co_wrt_co g3 (g_Var_f x)) in
let B3 := co_subst_co_tm (g_Cast (g_Var_f x) (g_Sym g1)) x B2 in
(a_CPi phi1 (close_tm_wrt_co x B1), a_CPi phi2 (close_tm_wrt_co x B3))
| g_CAbsCong g1 g2 g3 =>
let (phi1,phi2) := get_iso_n m G g1 in
let (x,_) := atom_fresh (dom G) in
let (b1,b2) := get_deq_n m ([(x,Co phi1)] ++ G)
(open_co_wrt_co g2 (g_Var_f x)) in
let b3 := co_subst_co_tm (g_Cast (g_Var_f x) (g_Sym g1)) x b2 in
(a_CAbs phi1 (close_tm_wrt_co x b1), a_CAbs phi2 (close_tm_wrt_co x b3))
| (g_CAppCong g1 g2 g3) =>
let (a1, b1) := get_deq_n m G g1 in
(a_CApp a1 g2,a_CApp b1 g3)
| (g_CPiSnd g1 g2 g3) =>
match get_deq_n m G g1 with
| (a_CPi (Eq a a' A) B1, a_CPi (Eq b b' B) B2) =>
(open_tm_wrt_co  B1   g2, open_tm_wrt_co  B2   g3 )
| (_,_) => (a_Star, a_Star)
end
| (g_Cast g1 g2) =>
match get_iso_n m G g2 with
| (Eq a a' A, Eq b b' B) => (b,b')
end
|  (g_IsoSnd g) =>
match get_iso_n m G g with
| (Eq a a' A, Eq b b' B) => (A, B)
end
| (g_Eta b) =>
let (x,_) := atom_fresh (dom G) in
match get_tpg_n m G b with
| (a_Pi rho A B) => (a_Abs rho A (close_tm_wrt_tm x (a_App b rho (a_Var_f x))), b)
| (a_CPi phi _) =>  (a_CAbs phi (close_tm_wrt_co x (a_CApp b (g_Var_f x))), b)
| _ => (a_Star, a_Star)
end
(* Left/Right | (g_Left g1 g2) => match get_deq_n m G g1 with | (a_App a _ _, a_App a' _ _) => (a,a') | (a_CApp a _, a_CApp a' _) => (a,a') | (_,_) => (a_Star, a_Star) end | (g_Right g1 g2) => match get_deq_n m G g1 with | (a_App _ _ a, a_App _ _ a') => (a,a') | (_,_) => (a_Star, a_Star) end *)
| _ => (a_Star, a_Star)
end
end.
Definition get_tpg (G : context) (a:tm) : tm :=
get_tpg_n (size_tm a) G a.
Definition get_deq (G : context) (g:co) : (tm*tm) :=
get_deq_n (size_co g) G g.
Definition get_iso (G : context) (g:co) : (constraint*constraint) :=
get_iso_n (size_co g) G g.

(* Specifications: *)
Lemma get_n_correct : forall n,
(forall G a A B, size_tm a <= n -> AnnTyping G a A -> get_tpg_n n G a = B -> A = B) /\
(forall G D g A B A' B', size_co g <= n -> AnnDefEq G D g A B ->
get_deq_n n G g = (A',B') -> A = A' /\ B = B') /\
(forall G D g A B A' B', size_co g <= n -> AnnIso G D g A B ->
get_iso_n n G g = (A',B') -> A = A' /\ B = B').
Lemma get_tpg_correct : (forall G a A B, AnnTyping G a A -> get_tpg G a = B -> A = B).
Lemma get_deq_correct: (forall G D g A B A' B',  AnnDefEq G D g A B ->
get_deq G g = (A',B') -> A = A' /\ B = B').
Lemma get_iso_correct: (forall G D g A B A' B',  AnnIso G D g A B ->
get_iso G g = (A',B') -> A = A' /\ B = B').
Lemma An_PiCong_exists2: forall x1 x2 (G:context) D rho
(g1 g2 : co) (A1 B1 A2 B3 B2 : tm),
x1 `notin` (dom G \u fv_tm_tm_tm B1 \u fv_tm_tm_tm B2 \u  fv_tm_tm_co g2)
-> x2 `notin` (dom G \u singleton x1 \u fv_tm_tm_tm B2 \u fv_tm_tm_tm B3 \u  fv_tm_tm_co g1)
-> AnnDefEq G D g1 A1 A2
→ AnnDefEq ([(x1, Tm A1)] ++ G) D (open_co_wrt_tm g2 (a_Var_f x1))
(open_tm_wrt_tm B1 (a_Var_f x1)) (open_tm_wrt_tm B2 (a_Var_f x1))
→ (open_tm_wrt_tm B3 (a_Var_f x2) =
open_tm_wrt_tm B2 (a_Conv (a_Var_f x2) (g_Sym g1)))
→ get_tpg G A1 = a_Star
→ get_tpg ([(x1,Tm A1)] ++ G) (open_tm_wrt_tm B1 (a_Var_f x1)) = a_Star
→ get_tpg ([(x1,Tm A1)] ++ G) (open_tm_wrt_tm B2 (a_Var_f x1)) = a_Star
→ get_tpg G A2 = a_Star
→ get_tpg ([(x1,Tm A2)] ++ G) (open_tm_wrt_tm B3 (a_Var_f x1)) = a_Star
→ AnnDefEq G D (g_PiCong rho g1 g2) (a_Pi rho A1 B1) (a_Pi rho A2 B3).
Lemma An_PiCong_exists3: forall x (G:context) D rho
(g1 g2 : co) (A1 B1 A2 B3 B2 : tm),
x `notin` (dom G \u fv_tm_tm_co g2 \u fv_tm_tm_co g1)
-> AnnDefEq G D g1 A1 A2
→ AnnDefEq ([(x, Tm A1)] ++ G) D (open_co_wrt_tm g2 (a_Var_f x)) B1 B2
→ B3 = tm_subst_tm_tm (a_Conv (a_Var_f x) (g_Sym g1)) x B2
→ get_tpg G A1 = a_Star
→ get_tpg ([(x,Tm A1)] ++ G) B1 = a_Star
→ get_tpg ([(x,Tm A1)] ++ G) B2 = a_Star
→ get_tpg G A2 = a_Star
→ get_tpg ([(x,Tm A2)] ++ G) B3 = a_Star
→ AnnDefEq G D (g_PiCong rho g1 g2) (a_Pi rho A1 (close_tm_wrt_tm x B1)) (a_Pi rho A2 (close_tm_wrt_tm x B3)).
Lemma An_AbsCong_exists3: forall x (G:context) D rho
(g1 g2 : co) (A1 B1 A2 B3 B2 B: tm),
x `notin` (dom G \u fv_tm_tm_co g2 \u fv_tm_tm_co g1)
-> AnnDefEq G D g1 A1 A2
→ AnnDefEq ([(x, Tm A1)] ++ G) D (open_co_wrt_tm g2 (a_Var_f x)) B1 B2
→ B3 = tm_subst_tm_tm (a_Conv (a_Var_f x) (g_Sym g1)) x B2
→ get_tpg G A1 = a_Star
→ get_tpg ([(x,Tm A1)] ++ G) B2 = B (* FIXME: isn't this assumption useless? (B seems to only occur here) *)
→ get_tpg G A2 = a_Star
→ RhoCheck rho x (erase_tm B1)
→ RhoCheck rho x (erase_tm B3)
→ AnnDefEq G D (g_AbsCong rho g1 g2)
(a_Abs rho A1 (close_tm_wrt_tm x B1))
(a_Abs rho A2 (close_tm_wrt_tm x B3)).
Lemma An_CPiCong_exists_3 :  ∀ c (G : context) D (g1 g3 : co) (phi1 : constraint)
(B1 : tm) (phi2 : constraint) (B3 B2 : tm),
c `notin` dom G \u D \u fv_co_co_co g3 \u fv_co_co_co g1
-> AnnIso G D g1 phi1 phi2
→ AnnDefEq ([(c, Co phi1)] ++ G) D (open_co_wrt_co g3 (g_Var_f c)) B1 B2
→ B3 = co_subst_co_tm (g_Cast (g_Var_f c) (g_Sym g1)) c B2
-> get_tpg ([(c,Co phi1)] ++ G) B1 = a_Star
-> get_tpg ([(c,Co phi2)] ++ G) B3 = a_Star
-> get_tpg ([(c,Co phi1)] ++ G) B2 = a_Star
→ AnnDefEq G D (g_CPiCong g1 g3) (a_CPi phi1 (close_tm_wrt_co c B1))
(a_CPi phi2 (close_tm_wrt_co c B3)).
Lemma An_CAbsCong_exists3 :
∀ (c : atom) (G : context) (D : available_props)
(g1 g3 g4 : co) (phi1 : constraint) (a1 : tm)
(phi2 : constraint) (a3 a2 B1 B3 : tm),
AnnIso G D g1 phi1 phi2
→ c `notin` dom G \u D \u (fv_co_co_co g3) \u (fv_co_co_co g1)
\u fv_co_co_co g4
→ AnnDefEq ([(c, Co phi1)] ++ G) D (open_co_wrt_co g3 (g_Var_f c)) a1 a2
→ a3 = co_subst_co_tm (g_Cast (g_Var_f c) (g_Sym g1)) c a2
→ get_tpg ([(c, Co phi1)] ++ G) a1 = B1
-> get_tpg ([(c, Co phi2)] ++ G) a3 = B3
→ AnnDefEq G (dom G) g4 (a_CPi phi1 (close_tm_wrt_co c B1))
(a_CPi phi2 (close_tm_wrt_co c B3))
→ AnnDefEq G D (g_CAbsCong g1 g3 g4)
(a_CAbs phi1 (close_tm_wrt_co c a1))
(a_CAbs phi2 (close_tm_wrt_co c a3))
.