(* For unfolding all definitions that hide pair constructors (So the tactics can reach them)*)
Create HintDb pair.
(* For unfolding pair constructors (for internal use)*)
Create HintDb deep_pair. (*TODO: add the Hiint Unfold for all constructors*)
Notation "'Pair'  T " := (T * T)%type (at level 100).
Create HintDb pair.
Definition Liftable (f: Type -> Type):=
forall a b, f (a -> b) -> (f a -> f b).
(* OLD version*)
(*Definition func_pair {T1 T2: Type} (f:T1 -> T2): (Pair T1) -> Pair T2:= fun aa:Pair T1 => (f (fst aa), f (snd aa)). Definition pair_appl {T1 T2: Type}  (f: Pair (T1 -> T2)) (a: Pair T1):= ((fst f) (fst a),(snd f) (snd a)). Definition func_pair2 {T1 T2 T3: Type} (f:T1 -> T2 -> T3):= fun aa bb=> pair_appl (func_pair f aa) bb. Definition mk_pair {T:Type} (a:T): Pair T:= (a,a). *)
Definition pair_appl: Liftable (fun x=> Pair x):=
fun a b (f : Pair a -> b) aa => (fst f (fst aa), snd f (snd aa)).
Arguments pair_appl {_ _} f.
Definition pair0 {T} (x:T): Pair T:= (x,x).
Notation "g ̊" := (compose g) (at level 8, left associativity).
Definition pair1 {T1 T2}: (T1 -> T2) -> _:=
pair_appl ̊ pair0.
Definition pair2 {T1 T2 T3}: (T1 -> T2 -> T3) -> _:=
pair_appl ̊̊ pair1.
Definition pair3 {T1 T2 T3 T4}: (T1 -> T2 -> T3 -> T4) -> _:=
pair_appl ̊̊̊ pair2.
(* 'Pair Prop' ~~ /\ *)
Definition pair_prop (a: Pair Prop): Prop:= fst a /\ snd a.
Definition pair0_prop:= pair_prop ̊ pair0.
Definition pair1_prop {T1}: (T1 -> Prop) -> _:=
pair_prop ̊̊ pair1.
Definition pair2_prop {T1 T2}: (T1 -> T2 -> Prop) -> _:=
pair_prop ̊̊̊ pair2.
Definition pair3_prop {T1 T2 T3}: (T1 -> T2 -> T3 -> Prop) -> _:=
pair_prop ̊̊̊̊ pair3.
(* F preserves P*)
Definition impredicative
{k}
(F:(forall x : Type, k x -> k (Pair x)))
(P:forall {T}, k T -> Prop)
:= forall {A} (R:k A),
(*F A R := "Pair R" *)
P R -> P (F A R).
(* Impredicatiive relation *)
(* Lifting Pairs preserves prediicates over relations *)
Definition impr_relation:=
@impredicative relation (fun T => @pair2_prop T T).
Definition impr_func:=
@impredicative (fun t=> t) (fun _ T => pair0 T).
Ltac destruct_and_simpl H:=
let H1:= fresh in
let H2:= fresh in
destruct H as [H1 H2]; simpl in H1, H2.
Ltac destruct_pair_and:=
match goal with
|[H: pair0_prop _ |- _] => destruct_and_simpl H
|[H: pair1_prop _ _ |- _] => destruct_and_simpl H
|[H: pair2_prop _ _ _ |- _] => destruct_and_simpl H
|[H: pair3_prop _ _ _ _ |- _] => destruct_and_simpl H
end.
Ltac solve_impr_rel:=
(*INIT*)
let A:= fresh in
let R:= fresh in
let HH:= fresh in
intros A R HH;
(* !goal ?P (pair2_prop R) *)
split; simpl; intros; repeat destruct_pair_and;
(* !goal ?P (fun x y => R (fst x) (fst y))   *)
(* !goal ?P (fun x y => R (snd x) (snd y))   *)
eapply HH; eauto.

Lemma single_pair_impl
: forall (x: Prop) (Y : Pair Prop),
pair_prop (x -> fst Y, x -> snd Y) ->
x -> pair_prop Y.