(* Autor(s): Andrej Dudenhefner (1) Affiliation(s): (1) Saarland University, Saarbrücken, Germany  Description: Theorem "pure_typable_intro_prenex" can be used to introduce/eliminate closed assumption ∀..∀.s where s is simple. Theorem "pure_typable_intro_poly_arr_0_0" can be used to introduce/eliminate the assumption 0 -> 0 [1].  Related Work: [1] Wells, Joe B. "Typability and Type-Checking in the Second-Order lambda-Calculus are Equivalent and Undecidable." Proceedings Ninth Annual IEEE Symposium on Logic In Computer Science. IEEE, 1994. *)
From Undecidability.SystemF.Util Require Import Facts poly_type_facts pure_term_facts term_facts typing_facts iipc2_facts pure_typing_facts.
(* (\_.M) N *)
Definition K' M N := pure_app (pure_abs (ren_pure_term S M)) N.
Definition Mω := pure_abs (pure_app (pure_var 0) (pure_var 0)).
(* \x. K x (K (\w.(x (x w))) N) N can be used to work further with x *)
Definition M_Wells N :=
pure_abs (K' (pure_var 0) (K' (pure_abs (pure_app (pure_var 1) (pure_app (pure_var 1) (pure_var 0)))) N)).
(* (\y. K (y y) (y Mω)) (M_Wells N) *)
Definition M_Wells_J N := pure_app
(pure_abs (K' (pure_app (pure_var 0) (pure_var 0)) (pure_app (pure_var 0) Mω)))
(M_Wells N).
Ltac first_pure_typingE :=
match goal with
| |- pure_typing _ (pure_app _ _) (poly_var _) -> _  =>
move=> /pure_typingE' [?] [?] [+] [+] ?
| |- pure_typing _ (pure_app _ _) (poly_arr _ _) -> _ =>
move=> /pure_typingE' [?] [?] [+] [+] ?
| |- pure_typing _ (pure_app _ _) _ -> _ =>
move=> /pure_typingE [?] [?] [?] [?] [+] [+] [? ?]
| |- pure_typing _ (pure_abs _) (poly_arr _ _) -> _ =>
move=> /pure_typingE'
| |- pure_typing _ (pure_abs _) _ -> _ =>
move=> /pure_typingE [?] [?] [?] [+ ?]
| |- pure_typing _ (pure_var _) (poly_var _) -> _ =>
move=> /pure_typingE' [?] [[?]] ?
| |- pure_typing _ (pure_var _) (poly_arr _ _) -> _ =>
move=> /pure_typingE' [?] [[?]] ?
| |- pure_typing _ (pure_var _) _ -> _ =>
move=> /pure_typingE [?] [?] [?] [[?]] [? ?]
| |- pure_typing _ (K' _ _) _ -> _ =>
move=> /pure_typing_K'E []
| |- pure_typable _ (K' _ _) -> _ =>
move=> /pure_typable_K'E []
| |- pure_typable _ (pure_var _) -> _ =>
move=> _
| |- pure_typable _ (pure_app _ _) -> _ =>
move=> /pure_typableE [?] [?] []
| |- pure_typable _ (pure_abs _) -> _ =>
move=> /pure_typableE [?]
end.
Ltac simplify_poly_type_eqs :=
match goal with
| H : contains (poly_var _) _ |- _ =>
move: H => /containsE ?
| H : contains (poly_arr _ _) _ |- _ =>
move: H => /containsE ?
| H : contains (many_poly_abs _ (poly_arr _ _)) (poly_arr _ _) |- _ =>
move: H => /contains_poly_arrE [?] [?] [? ?]
| H : contains (subst_poly_type (fold_right scons poly_var _) _) _ |- _ =>
move /contains_subst_poly_type_fold_rightE in H; rewrite ?many_poly_abs_many_poly_abs in H
| H : many_poly_abs _ (poly_var _) = subst_poly_type _ _ |- _ =>
move: H => /many_poly_abs_poly_var_eq_subst_poly_typeE => [[?]] [?] [?] [? ?]
| H : contains (ren_poly_type _ (ren_poly_type _ _)) _ |- _ =>
rewrite ?renRen_poly_type /= in H
| H : contains (ren_poly_type _ (many_poly_abs ?n (poly_var (?n + _)))) _ |- _ =>
rewrite ren_poly_type_many_poly_abs /= iter_up_ren in H
| H : contains (ren_poly_type _ (many_poly_abs ?n (poly_arr (poly_var (?n + _)) (poly_var (?n + _))))) _ |- _ =>
rewrite ren_poly_type_many_poly_abs /= ?iter_up_ren in H
| H : contains (many_poly_abs ?n (poly_var (?n + _))) _ |- _ =>
move: H => /contains_many_poly_abs_free [?] [?] [? ?]
| H : poly_arr _ _ = many_poly_abs ?n _ |- _ =>
(have ? : n = 0 by move : (n) H; case); subst n; rewrite /= in H
| H : many_poly_abs ?n _ = poly_var _ |- _ =>
(have ? : n = 0 by move : (n) H; case); subst n; rewrite /= in H
| H : poly_var _ = poly_var _ |- _ =>
move: H => [?]
end.
Arguments funcomp {X Y Z} _ _ / _.
(* ∀a.∀b.a -> b -> b -> a *)
Definition poly_abba := poly_abs (poly_abs (poly_arr (poly_var 1) (poly_arr (poly_var 0) (poly_arr (poly_var 0) (poly_var 1))))).

Lemma contains_poly_abbaI {s t s' t'} : s' = s -> t' = t ->
contains poly_abba (poly_arr s (poly_arr t (poly_arr t' s'))).