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.

Lemma get_tpg_correct : (forall G a A B, AnnTyping G a A -> get_tpg G a = B -> A = B).