From Hammer Require Import Hammer.

Set Warnings "-notation-overridden,-parsing".
From PLF Require Import Maps.
From PLF Require Import Types.
From PLF Require Import Smallstep.
From PLF Require Import Stlc.
From Coq Require Import Strings.String.

Module STLCExtended.

Inductive ty : Type :=
| Arrow : ty -> ty -> ty
| Nat  : ty
| Sum  : ty -> ty -> ty
| List : ty -> ty
| Unit : ty
| Prod : ty -> ty -> ty.

Inductive tm : Type :=

| var : string -> tm
| app : tm -> tm -> tm
| abs : string -> ty -> tm -> tm

| const : nat -> tm
| scc : tm -> tm
| prd : tm -> tm
| mlt : tm -> tm -> tm
| test0  : tm -> tm -> tm -> tm

| tinl : ty -> tm -> tm
| tinr : ty -> tm -> tm
| tcase : tm -> string -> tm -> string -> tm -> tm

| tnil : ty -> tm
| tcons : tm -> tm -> tm
| tlcase : tm -> tm -> string -> string -> tm -> tm

| unit : tm

| pair : tm -> tm -> tm
| fst : tm -> tm
| snd : tm -> tm

| tlet : string -> tm -> tm -> tm

| tfix  : tm -> tm.

Fixpoint subst (x : string) (s : tm) (t : tm) : tm :=
match t with

| var y =>
if eqb_string x y then s else t
| abs y T t1 =>
abs y T (if eqb_string x y then t1 else (subst x s t1))
| app t1 t2 =>
app (subst x s t1) (subst x s t2)

| const n =>
const n
| scc t1 =>
scc (subst x s t1)
| prd t1 =>
prd (subst x s t1)
| mlt t1 t2 =>
mlt (subst x s t1) (subst x s t2)
| test0 t1 t2 t3 =>
test0 (subst x s t1) (subst x s t2) (subst x s t3)

| tinl T t1 =>
tinl T (subst x s t1)
| tinr T t1 =>
tinr T (subst x s t1)
| tcase t0 y1 t1 y2 t2 =>
tcase (subst x s t0)
y1 (if eqb_string x y1 then t1 else (subst x s t1))
y2 (if eqb_string x y2 then t2 else (subst x s t2))

| tnil T =>
tnil T
| tcons t1 t2 =>
tcons (subst x s t1) (subst x s t2)
| tlcase t1 t2 y1 y2 t3 =>
tlcase (subst x s t1) (subst x s t2) y1 y2
(if eqb_string x y1 then
t3
else if eqb_string x y2 then t3
else (subst x s t3))

| unit => unit

| _ => t
end.

Notation "'[' x ':=' s ']' t" := (subst x s t) (at level 20).

Inductive value : tm -> Prop :=

| v_abs : forall x T11 t12,
value (abs x T11 t12)

| v_nat : forall n1,
value (const n1)

| v_inl : forall v T,
value v ->
value (tinl T v)
| v_inr : forall v T,
value v ->
value (tinr T v)

| v_lnil : forall T, value (tnil T)
| v_lcons : forall v1 vl,
value v1 ->
value vl ->
value (tcons v1 vl)

| v_unit : value unit

| v_pair : forall v1 v2,
value v1 ->
value v2 ->
value (pair v1 v2).

Hint Constructors value.

Reserved Notation "t1 '-->' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=

| ST_AppAbs : forall x T11 t12 v2,
value v2 ->
(app (abs x T11 t12) v2) --> [x:=v2]t12
| ST_App1 : forall t1 t1' t2,
t1 --> t1' ->
(app t1 t2) --> (app t1' t2)
| ST_App2 : forall v1 t2 t2',
value v1 ->
t2 --> t2' ->
(app v1 t2) --> (app v1 t2')

| ST_Succ1 : forall t1 t1',
t1 --> t1' ->
(scc t1) --> (scc t1')
| ST_SuccNat : forall n1,
(scc (const n1)) --> (const (S n1))
| ST_Pred : forall t1 t1',
t1 --> t1' ->
(prd t1) --> (prd t1')
| ST_PredNat : forall n1,
(prd (const n1)) --> (const (pred n1))
| ST_Mult1 : forall t1 t1' t2,
t1 --> t1' ->
(mlt t1 t2) --> (mlt t1' t2)
| ST_Mult2 : forall v1 t2 t2',
value v1 ->
t2 --> t2' ->
(mlt v1 t2) --> (mlt v1 t2')
| ST_Mulconsts : forall n1 n2,
(mlt (const n1) (const n2)) --> (const (mult n1 n2))
| ST_Test01 : forall t1 t1' t2 t3,
t1 --> t1' ->
(test0 t1 t2 t3) --> (test0 t1' t2 t3)
| ST_Test0Zero : forall t2 t3,
(test0 (const 0) t2 t3) --> t2
| ST_Test0Nonzero : forall n t2 t3,
(test0 (const (S n)) t2 t3) --> t3

| ST_Inl : forall t1 t1' T,
t1 --> t1' ->
(tinl T t1) --> (tinl T t1')
| ST_Inr : forall t1 t1' T,
t1 --> t1' ->
(tinr T t1) --> (tinr T t1')
| ST_Case : forall t0 t0' x1 t1 x2 t2,
t0 --> t0' ->
(tcase t0 x1 t1 x2 t2) --> (tcase t0' x1 t1 x2 t2)
| ST_CaseInl : forall v0 x1 t1 x2 t2 T,
value v0 ->
(tcase (tinl T v0) x1 t1 x2 t2) --> [x1:=v0]t1
| ST_CaseInr : forall v0 x1 t1 x2 t2 T,
value v0 ->
(tcase (tinr T v0) x1 t1 x2 t2) --> [x2:=v0]t2

| ST_Cons1 : forall t1 t1' t2,
t1 --> t1' ->
(tcons t1 t2) --> (tcons t1' t2)
| ST_Cons2 : forall v1 t2 t2',
value v1 ->
t2 --> t2' ->
(tcons v1 t2) --> (tcons v1 t2')
| ST_Lcase1 : forall t1 t1' t2 x1 x2 t3,
t1 --> t1' ->
(tlcase t1 t2 x1 x2 t3) --> (tlcase t1' t2 x1 x2 t3)
| ST_LcaseNil : forall T t2 x1 x2 t3,
(tlcase (tnil T) t2 x1 x2 t3) --> t2
| ST_LcaseCons : forall v1 vl t2 x1 x2 t3,
value v1 ->
value vl ->
(tlcase (tcons v1 vl) t2 x1 x2 t3)
--> (subst x2 vl (subst x1 v1 t3))

where "t1 '-->' t2" := (step t1 t2).

Notation multistep := (multi step).
Notation "t1 '-->*' t2" := (multistep t1 t2) (at level 40).

Hint Constructors step.

Definition context := partial_map ty.

Reserved Notation "Gamma '|-' t '\in' T" (at level 40).

Inductive has_type : context -> tm -> ty -> Prop :=

| T_Var : forall Gamma x T,
Gamma x = Some T ->
Gamma |- (var x) \in T
| T_Abs : forall Gamma x T11 T12 t12,
(update Gamma x T11) |- t12 \in T12 ->
Gamma |- (abs x T11 t12) \in (Arrow T11 T12)
| T_App : forall T1 T2 Gamma t1 t2,
Gamma |- t1 \in (Arrow T1 T2) ->
Gamma |- t2 \in T1 ->
Gamma |- (app t1 t2) \in T2

| T_Nat : forall Gamma n1,
Gamma |- (const n1) \in Nat
| T_Succ : forall Gamma t1,
Gamma |- t1 \in Nat ->
Gamma |- (scc t1) \in Nat
| T_Pred : forall Gamma t1,
Gamma |- t1 \in Nat ->
Gamma |- (prd t1) \in Nat
| T_Mult : forall Gamma t1 t2,
Gamma |- t1 \in Nat ->
Gamma |- t2 \in Nat ->
Gamma |- (mlt t1 t2) \in Nat
| T_Test0 : forall Gamma t1 t2 t3 T1,
Gamma |- t1 \in Nat ->
Gamma |- t2 \in T1 ->
Gamma |- t3 \in T1 ->
Gamma |- (test0 t1 t2 t3) \in T1

| T_Inl : forall Gamma t1 T1 T2,
Gamma |- t1 \in T1 ->
Gamma |- (tinl T2 t1) \in (Sum T1 T2)
| T_Inr : forall Gamma t2 T1 T2,
Gamma |- t2 \in T2 ->
Gamma |- (tinr T1 t2) \in (Sum T1 T2)
| T_Case : forall Gamma t0 x1 T1 t1 x2 T2 t2 T,
Gamma |- t0 \in (Sum T1 T2) ->
(update Gamma x1 T1) |- t1 \in T ->
(update Gamma x2 T2) |- t2 \in T ->
Gamma |- (tcase t0 x1 t1 x2 t2) \in T

| T_Nil : forall Gamma T,
Gamma |- (tnil T) \in (List T)
| T_Cons : forall Gamma t1 t2 T1,
Gamma |- t1 \in T1 ->
Gamma |- t2 \in (List T1) ->
Gamma |- (tcons t1 t2) \in (List T1)
| T_Lcase : forall Gamma t1 T1 t2 x1 x2 t3 T2,
Gamma |- t1 \in (List T1) ->
Gamma |- t2 \in T2 ->
(update (update Gamma x2 (List T1)) x1 T1) |- t3 \in T2 ->
Gamma |- (tlcase t1 t2 x1 x2 t3) \in T2

| T_Unit : forall Gamma,
Gamma |- unit \in Unit

where "Gamma '|-' t '\in' T" := (has_type Gamma t T).

Hint Constructors has_type.

Definition manual_grade_for_extensions_definition : option (nat*string) := None.

Module Examples.

Open Scope string_scope.
Notation x := "x".
Notation y := "y".
Notation a := "a".
Notation f := "f".
Notation g := "g".
Notation l := "l".
Notation k := "k".
Notation i1 := "i1".
Notation i2 := "i2".
Notation processSum := "processSum".
Notation n := "n".
Notation eq := "eq".
Notation m := "m".
Notation evenodd := "evenodd".
Notation even := "even".
Notation odd := "odd".
Notation eo := "eo".

Hint Extern 2 (has_type _ (app _ _) _) =>
eapply T_App; auto.
Hint Extern 2 (has_type _ (tlcase _ _ _ _ _) _) =>
eapply T_Lcase; auto.
Hint Extern 2 (_ = _) => compute; reflexivity.

Module Numtest.

Definition test :=
test0
(prd
(scc
(prd
(mlt
(const 2)
(const 0)))))
(const 5)
(const 6).

Example typechecks :
empty |- test \in Nat.
Proof. hammer_hook "MoreStlc" "MoreStlc.STLCExtended.Examples.Numtest.typechecks".
unfold test.

auto 10.
Admitted.

Example numtest_reduces :
test -->* const 5.
Proof. hammer_hook "MoreStlc" "MoreStlc.STLCExtended.Examples.Numtest.numtest_reduces".

Admitted.

End Numtest.

Module Prodtest.

Definition test :=
snd
(fst
(pair
(pair
(const 5)
(const 6))
(const 7))).

Example typechecks :
empty |- test \in Nat.
Proof. hammer_hook "MoreStlc" "MoreStlc.STLCExtended.Examples.Prodtest.typechecks". unfold test. eauto 15.  Admitted.

Example reduces :
test -->* const 6.
Proof. hammer_hook "MoreStlc" "MoreStlc.STLCExtended.Examples.Prodtest.reduces".

Admitted.

End Prodtest.

Module LetTest.

Definition test :=
tlet
x
(prd (const 6))
(scc (var x)).

Example typechecks :
empty |- test \in Nat.
Proof. hammer_hook "MoreStlc" "MoreStlc.STLCExtended.Examples.LetTest.typechecks". unfold test. eauto 15.  Admitted.

Example reduces :
test -->* const 6.
Proof. hammer_hook "MoreStlc" "MoreStlc.STLCExtended.Examples.LetTest.reduces".

Admitted.

End LetTest.

Module Sumtest1.

Definition test :=
tcase (tinl Nat (const 5))
x (var x)
y (var y).

Example typechecks :
empty |- test \in Nat.
Proof. hammer_hook "MoreStlc" "MoreStlc.STLCExtended.Examples.Sumtest1.typechecks". unfold test. eauto 15.  Admitted.

Example reduces :
test -->* (const 5).
Proof. hammer_hook "MoreStlc" "MoreStlc.STLCExtended.Examples.Sumtest1.reduces".

Admitted.

End Sumtest1.

Module Sumtest2.

Definition test :=
tlet
processSum
(abs x (Sum Nat Nat)
(tcase (var x)
n (var n)
n (test0 (var n) (const 1) (const 0))))
(pair
(app (var processSum) (tinl Nat (const 5)))
(app (var processSum) (tinr Nat (const 5)))).

Example typechecks :
empty |- test \in (Prod Nat Nat).
Proof. hammer_hook "MoreStlc" "MoreStlc.STLCExtended.Examples.Sumtest2.typechecks". unfold test. eauto 15.  Admitted.

Example reduces :
test -->* (pair (const 5) (const 0)).
Proof. hammer_hook "MoreStlc" "MoreStlc.STLCExtended.Examples.Sumtest2.reduces".

Admitted.

End Sumtest2.

Module ListTest.

Definition test :=
tlet l
(tcons (const 5) (tcons (const 6) (tnil Nat)))
(tlcase (var l)
(const 0)
x y (mlt (var x) (var x))).

Example typechecks :
empty |- test \in Nat.
Proof. hammer_hook "MoreStlc" "MoreStlc.STLCExtended.Examples.ListTest.typechecks". unfold test. eauto 20.  Admitted.

Example reduces :
test -->* (const 25).
Proof. hammer_hook "MoreStlc" "MoreStlc.STLCExtended.Examples.ListTest.reduces".

Admitted.

End ListTest.

Module FixTest1.

Definition fact :=
tfix
(abs f (Arrow Nat Nat)
(abs a Nat
(test0
(var a)
(const 1)
(mlt
(var a)
(app (var f) (prd (var a))))))).

Example typechecks :
empty |- fact \in (Arrow Nat Nat).
Proof. hammer_hook "MoreStlc" "MoreStlc.STLCExtended.Examples.FixTest1.typechecks". unfold fact. auto 10.  Admitted.

Example reduces :
(app fact (const 4)) -->* (const 24).
Proof. hammer_hook "MoreStlc" "MoreStlc.STLCExtended.Examples.FixTest1.reduces".

Admitted.

End FixTest1.

Module FixTest2.

Definition map :=
abs g (Arrow Nat Nat)
(tfix
(abs f (Arrow (List Nat) (List Nat))
(abs l (List Nat)
(tlcase (var l)
(tnil Nat)
a l (tcons (app (var g) (var a))
(app (var f) (var l))))))).

Example typechecks :
empty |- map \in
(Arrow (Arrow Nat Nat)
(Arrow (List Nat)
(List Nat))).
Proof. hammer_hook "MoreStlc" "MoreStlc.STLCExtended.Examples.FixTest2.typechecks". unfold map. auto 10.  Admitted.

Example reduces :
app (app map (abs a Nat (scc (var a))))
(tcons (const 1) (tcons (const 2) (tnil Nat)))
-->* (tcons (const 2) (tcons (const 3) (tnil Nat))).
Proof. hammer_hook "MoreStlc" "MoreStlc.STLCExtended.Examples.FixTest2.reduces".

Admitted.

End FixTest2.

Module FixTest3.

Definition equal :=
tfix
(abs eq (Arrow Nat (Arrow Nat Nat))
(abs m Nat
(abs n Nat
(test0 (var m)
(test0 (var n) (const 1) (const 0))
(test0 (var n)
(const 0)
(app (app (var eq)
(prd (var m)))
(prd (var n)))))))).

Example typechecks :
empty |- equal \in (Arrow Nat (Arrow Nat Nat)).
Proof. hammer_hook "MoreStlc" "MoreStlc.STLCExtended.Examples.FixTest3.typechecks". unfold equal. auto 10.  Admitted.

Example reduces :
(app (app equal (const 4)) (const 4)) -->* (const 1).
Proof. hammer_hook "MoreStlc" "MoreStlc.STLCExtended.Examples.FixTest3.reduces".

Admitted.

Example reduces2 :
(app (app equal (const 4)) (const 5)) -->* (const 0).
Proof. hammer_hook "MoreStlc" "MoreStlc.STLCExtended.Examples.FixTest3.reduces2".

Admitted.

End FixTest3.

Module FixTest4.

Definition eotest :=
tlet evenodd
(tfix
(abs eo (Prod (Arrow Nat Nat) (Arrow Nat Nat))
(pair
(abs n Nat
(test0 (var n)
(const 1)
(app (snd (var eo)) (prd (var n)))))
(abs n Nat
(test0 (var n)
(const 0)
(app (fst (var eo)) (prd (var n))))))))
(tlet even (fst (var evenodd))
(tlet odd (snd (var evenodd))
(pair
(app (var even) (const 3))
(app (var even) (const 4))))).

Example typechecks :
empty |- eotest \in (Prod Nat Nat).
Proof. hammer_hook "MoreStlc" "MoreStlc.STLCExtended.Examples.FixTest4.typechecks". unfold eotest. eauto 30.  Admitted.

Example reduces :
eotest -->* (pair (const 0) (const 1)).
Proof. hammer_hook "MoreStlc" "MoreStlc.STLCExtended.Examples.FixTest4.reduces".

Admitted.

End FixTest4.

End Examples.

Theorem progress : forall t T,
empty |- t \in T ->
value t \/ exists t', t --> t'.
Proof with eauto. hammer_hook "MoreStlc" "MoreStlc.STLCExtended.progress".
intros t T Ht.
remember empty as Gamma.
generalize dependent HeqGamma.
induction Ht; intros HeqGamma; subst.
-

inversion H.
-

left...
-

right.
destruct IHHt1; subst...
+
destruct IHHt2; subst...
*

inversion H; subst; try solve_by_invert.
exists (subst x t2 t12)...
*

inversion H0 as [t2' Hstp]. exists (app t1 t2')...
+

inversion H as [t1' Hstp]. exists (app t1' t2)...
-
left...
-
right.
destruct IHHt...
+
inversion H; subst; try solve_by_invert.
exists (const (S n1))...
+
inversion H as [t1' Hstp].
exists (scc t1')...
-
right.
destruct IHHt...
+
inversion H; subst; try solve_by_invert.
exists (const (pred n1))...
+
inversion H as [t1' Hstp].
exists (prd t1')...
-
right.
destruct IHHt1...
+
destruct IHHt2...
*
inversion H; subst; try solve_by_invert.
inversion H0; subst; try solve_by_invert.
exists (const (mult n1 n0))...
*
inversion H0 as [t2' Hstp].
exists (mlt t1 t2')...
+
inversion H as [t1' Hstp].
exists (mlt t1' t2)...
-
right.
destruct IHHt1...
+
inversion H; subst; try solve_by_invert.
destruct n1 as [|n1'].
*
exists t2...
*
exists t3...
+
inversion H as [t1' H0].
exists (test0 t1' t2 t3)...
-
destruct IHHt...
+
right. inversion H as [t1' Hstp]...

-
destruct IHHt...
+
right. inversion H as [t1' Hstp]...

-
right.
destruct IHHt1...
+
inversion H; subst; try solve_by_invert.
*
exists ([x1:=v]t1)...
*
exists ([x2:=v]t2)...
+
inversion H as [t0' Hstp].
exists (tcase t0' x1 t1 x2 t2)...
-
left...
-
destruct IHHt1...
+
destruct IHHt2...
*
right. inversion H0 as [t2' Hstp].
exists (tcons t1 t2')...
+
right. inversion H as [t1' Hstp].
exists (tcons t1' t2)...
-
right.
destruct IHHt1...
+
inversion H; subst; try solve_by_invert.
*
exists t2...
*
exists ([x2:=vl]([x1:=v1]t3))...
+
inversion H as [t1' Hstp].
exists (tlcase t1' t2 x1 x2 t3)...
-
left...

Admitted.

Definition manual_grade_for_progress : option (nat*string) := None.

Inductive appears_free_in : string -> tm -> Prop :=
| afi_var : forall x,
appears_free_in x (var x)
| afi_app1 : forall x t1 t2,
appears_free_in x t1 -> appears_free_in x (app t1 t2)
| afi_app2 : forall x t1 t2,
appears_free_in x t2 -> appears_free_in x (app t1 t2)
| afi_abs : forall x y T11 t12,
y <> x  ->
appears_free_in x t12 ->
appears_free_in x (abs y T11 t12)

| afi_succ : forall x t,
appears_free_in x t ->
appears_free_in x (scc t)
| afi_pred : forall x t,
appears_free_in x t ->
appears_free_in x (prd t)
| afi_mult1 : forall x t1 t2,
appears_free_in x t1 ->
appears_free_in x (mlt t1 t2)
| afi_mult2 : forall x t1 t2,
appears_free_in x t2 ->
appears_free_in x (mlt t1 t2)
| afi_test01 : forall x t1 t2 t3,
appears_free_in x t1 ->
appears_free_in x (test0 t1 t2 t3)
| afi_test02 : forall x t1 t2 t3,
appears_free_in x t2 ->
appears_free_in x (test0 t1 t2 t3)
| afi_test03 : forall x t1 t2 t3,
appears_free_in x t3 ->
appears_free_in x (test0 t1 t2 t3)

| afi_inl : forall x t T,
appears_free_in x t ->
appears_free_in x (tinl T t)
| afi_inr : forall x t T,
appears_free_in x t ->
appears_free_in x (tinr T t)
| afi_case0 : forall x t0 x1 t1 x2 t2,
appears_free_in x t0 ->
appears_free_in x (tcase t0 x1 t1 x2 t2)
| afi_case1 : forall x t0 x1 t1 x2 t2,
x1 <> x ->
appears_free_in x t1 ->
appears_free_in x (tcase t0 x1 t1 x2 t2)
| afi_case2 : forall x t0 x1 t1 x2 t2,
x2 <> x ->
appears_free_in x t2 ->
appears_free_in x (tcase t0 x1 t1 x2 t2)

| afi_cons1 : forall x t1 t2,
appears_free_in x t1 ->
appears_free_in x (tcons t1 t2)
| afi_cons2 : forall x t1 t2,
appears_free_in x t2 ->
appears_free_in x (tcons t1 t2)
| afi_lcase1 : forall x t1 t2 y1 y2 t3,
appears_free_in x t1 ->
appears_free_in x (tlcase t1 t2 y1 y2 t3)
| afi_lcase2 : forall x t1 t2 y1 y2 t3,
appears_free_in x t2 ->
appears_free_in x (tlcase t1 t2 y1 y2 t3)
| afi_lcase3 : forall x t1 t2 y1 y2 t3,
y1 <> x ->
y2 <> x ->
appears_free_in x t3 ->
appears_free_in x (tlcase t1 t2 y1 y2 t3)

.

Hint Constructors appears_free_in.

Lemma context_invariance : forall Gamma Gamma' t S,
Gamma |- t \in S  ->
(forall x, appears_free_in x t -> Gamma x = Gamma' x)  ->
Gamma' |- t \in S.

Proof with eauto 30. hammer_hook "MoreStlc" "MoreStlc.STLCExtended.context_invariance".
intros. generalize dependent Gamma'.
induction H;
intros Gamma' Heqv...
-
apply T_Var... rewrite <- Heqv...
-
apply T_Abs... apply IHhas_type. intros y Hafi.
unfold update, t_update.
destruct (eqb_stringP x y)...
-
eapply T_Case...
+ apply IHhas_type2. intros y Hafi.
unfold update, t_update.
destruct (eqb_stringP x1 y)...
+ apply IHhas_type3. intros y Hafi.
unfold update, t_update.
destruct (eqb_stringP x2 y)...
-
eapply T_Lcase... apply IHhas_type3. intros y Hafi.
unfold update, t_update.
destruct (eqb_stringP x1 y)...
destruct (eqb_stringP x2 y)...

Admitted.

Lemma free_in_context : forall x t T Gamma,
appears_free_in x t ->
Gamma |- t \in T ->
exists T', Gamma x = Some T'.
Proof with eauto. hammer_hook "MoreStlc" "MoreStlc.STLCExtended.free_in_context".
intros x t T Gamma Hafi Htyp.
induction Htyp; inversion Hafi; subst...
-
destruct IHHtyp as [T' Hctx]... exists T'.
unfold update, t_update in Hctx.
rewrite false_eqb_string in Hctx...

-
destruct IHHtyp2 as [T' Hctx]... exists T'.
unfold update, t_update in Hctx.
rewrite false_eqb_string in Hctx...
-
destruct IHHtyp3 as [T' Hctx]... exists T'.
unfold update, t_update in Hctx.
rewrite false_eqb_string in Hctx...
-
clear Htyp1 IHHtyp1 Htyp2 IHHtyp2.
destruct IHHtyp3 as [T' Hctx]... exists T'.
unfold update, t_update in Hctx.
rewrite false_eqb_string in Hctx...
rewrite false_eqb_string in Hctx...

Admitted.

Definition manual_grade_for_context_invariance : option (nat*string) := None.

Lemma substitution_preserves_typing : forall Gamma x U v t S,
(update Gamma x U) |- t \in S  ->
empty |- v \in U   ->
Gamma |- ([x:=v]t) \in S.
Proof with eauto. hammer_hook "MoreStlc" "MoreStlc.STLCExtended.substitution_preserves_typing".

intros Gamma x U v t S Htypt Htypv.
generalize dependent Gamma. generalize dependent S.

induction t;
intros S Gamma Htypt; simpl; inversion Htypt; subst...
-
simpl. rename s into y.

unfold update, t_update in H1.
destruct (eqb_stringP x y).
+

subst.
inversion H1; subst. clear H1.
eapply context_invariance...
intros x Hcontra.
destruct (free_in_context _ _ S empty Hcontra)
as [T' HT']...
inversion HT'.
+

apply T_Var...
-
rename s into y. rename t into T11.

apply T_Abs...
destruct (eqb_stringP x y) as [Hxy|Hxy].
+

eapply context_invariance...
subst.
intros x Hafi. unfold update, t_update.
destruct (eqb_string y x)...
+

apply IHt. eapply context_invariance...
intros z Hafi. unfold update, t_update.
destruct (eqb_stringP y z) as [Hyz|Hyz]...
subst.
rewrite false_eqb_string...
-
rename s into x1. rename s0 into x2.
eapply T_Case...
+
destruct (eqb_stringP x x1) as [Hxx1|Hxx1].
*
eapply context_invariance...
subst.
intros z Hafi. unfold update, t_update.
destruct (eqb_string x1 z)...
*
apply IHt2. eapply context_invariance...
intros z Hafi.  unfold update, t_update.
destruct (eqb_stringP x1 z) as [Hx1z|Hx1z]...
subst. rewrite false_eqb_string...
+
destruct (eqb_stringP x x2) as [Hxx2|Hxx2].
*
eapply context_invariance...
subst.
intros z Hafi. unfold update, t_update.
destruct (eqb_string x2 z)...
*
apply IHt3. eapply context_invariance...
intros z Hafi.  unfold update, t_update.
destruct (eqb_stringP x2 z)...
subst. rewrite false_eqb_string...
-
rename s into y1. rename s0 into y2.
eapply T_Lcase...
destruct (eqb_stringP x y1).
+
simpl.
eapply context_invariance...
subst.
intros z Hafi. unfold update, t_update.
destruct (eqb_stringP y1 z)...
+
destruct (eqb_stringP x y2).
*
eapply context_invariance...
subst.
intros z Hafi. unfold update, t_update.
destruct (eqb_stringP y2 z)...
*
apply IHt3. eapply context_invariance...
intros z Hafi. unfold update, t_update.
destruct (eqb_stringP y1 z)...
subst. rewrite false_eqb_string...
destruct (eqb_stringP y2 z)...
subst. rewrite false_eqb_string...

Admitted.

Definition manual_grade_for_substitution_preserves_typing : option (nat*string) := None.

Theorem preservation : forall t t' T,
empty |- t \in T  ->
t --> t'  ->
empty |- t' \in T.
Proof with eauto. hammer_hook "MoreStlc" "MoreStlc.STLCExtended.preservation".
intros t t' T HT.

remember empty as Gamma. generalize dependent HeqGamma.
generalize dependent t'.

induction HT;
intros t' HeqGamma HE; subst; inversion HE; subst...
-

inversion HE; subst...
+

apply substitution_preserves_typing with T1...
inversion HT1...

-
inversion HT1; subst.
eapply substitution_preserves_typing...
-
inversion HT1; subst.
eapply substitution_preserves_typing...
-
+
inversion HT1; subst.
apply substitution_preserves_typing with (List T1)...
apply substitution_preserves_typing with T1...

Admitted.

Definition manual_grade_for_preservation : option (nat*string) := None.

End STLCExtended.


(*
 * Copyright (c) 2017-present,
 * Programming Research Laboratory (ROPAS), Seoul National University, Korea
 * This software is distributed under the term of the BSD-3 clause license.
 *)
(** Lattice constructor: sum.  *)

Set Implicit Arguments.

Require Import OrderedType.
Require Import hpattern vgtac.
Require Import VocabA DLat.
Require Import TStr.

Axiom sum_narrow_msg : string_t.
Extract Constant sum_narrow_msg => """narrow small big""".

Module SumKey (A : KEY) (B : KEY) <: KEY.

Inductive t' :=
| Inl (a : A.t)
| Inr (b : B.t).
Definition t := t'.

Inductive eq' : t -> t -> Prop :=
| eq_inl : forall (x' y' : A.t) (Heq: A.eq x' y'), eq' (Inl x') (Inl y')
| eq_inr : forall (x' y' : B.t) (Heq: B.eq x' y'), eq' (Inr x') (Inr y').

Definition eq : t -> t -> Prop := eq'.

Inductive lt' : t -> t -> Prop :=
| lt_inl : forall (x' y' : A.t) (Hlt: A.lt x' y'), lt' (Inl x') (Inl y')
| lt_inlr : forall (x' : A.t) (y' : B.t), lt' (Inl x') (Inr y')
| lt_inr : forall (x' y' : B.t) (Hlt: B.lt x' y'), lt' (Inr x') (Inr y').

Definition lt : t -> t -> Prop := lt'.

Lemma eq_refl : forall x : t, eq x x.
Proof. destruct x; econs; auto. Qed.
Lemma eq_sym : forall x y : t, eq x y -> eq y x.
Proof. inversion 1; econs; auto. Qed.
Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
Proof. inversion 1; inversion 1; econs; eauto. Qed.

Definition zb_eq : zb_equiv eq :=
  {| zb_equiv_refl := eq_refl
   ; zb_equiv_sym := eq_sym
   ; zb_equiv_trans := eq_trans |}.

Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
Proof. inversion 1; inversion 1; econs; eauto. Qed.
Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
Proof.
inversion 1; inversion 1; [eapply A.lt_not_eq|eapply B.lt_not_eq]; eauto.
Qed.

Definition compare (x y : t) : Compare lt eq x y :=
  match x, y with
    | Inl x', Inl y' =>
      match A.compare x' y' with
        | LT l => LT (lt_inl l)
        | EQ l => EQ (eq_inl l)
        | GT l => GT (lt_inl l)
      end
    | Inl x', Inr y' => LT (lt_inlr x' y')
    | Inr x', Inl y' => GT (lt_inlr y' x')
    | Inr x', Inr y' =>
      match B.compare x' y' with
        | LT l => LT (lt_inr l)
        | EQ l => EQ (eq_inr l)
        | GT l => GT (lt_inr l)
      end
  end.

Definition eq_dec (x y : t) : {eq x y} + {~ eq x y}.
refine match x, y with
         | Inl x', Inl y' =>
           match A.eq_dec x' y' with
             | left e => left (eq_inl e)
             | right _ => right _
           end
         | Inr x', Inr y' =>
           match B.eq_dec x' y' with
             | left e => left (eq_inr e)
             | right _ => right _
           end
         | _, _ => right _
       end; i; inv FH.
Qed.
Definition eqb x y := if eq_dec x y then true else false.

End SumKey.

Module Sum (A : LAT) (B : LAT) <: LAT.

Inductive t' :=
| Top
| Inl (a : A.t)
| Inr (b : B.t)
| Bot.

Definition t := t'.

Inductive le' : t -> t -> Prop :=
| le_top : forall (x : t), le' x Top
| le_bot : forall (x : t), le' Bot x
| le_inl : forall (x y : A.t) (Hle : A.le x y), le' (Inl x) (Inl y)
| le_inr : forall (x y : B.t) (Hle : B.le x y), le' (Inr x) (Inr y).

Definition le : t -> t -> Prop := le'.

Inductive eq' : t -> t -> Prop :=
| eq_top : eq' Top Top
| eq_bot : eq' Bot Bot
| eq_inl : forall (x y : A.t) (Heq : A.eq x y), eq' (Inl x) (Inl y)
| eq_inr : forall (x y : B.t) (Heq : B.eq x y), eq' (Inr x) (Inr y).

Definition eq : t -> t -> Prop := eq'.

Lemma le_refl : forall x y : t, eq x y -> le x y.
Proof. inversion 1; econs; auto using A.le_refl, B.le_refl. Qed.
Lemma le_antisym : forall x y : t, le x y -> le y x -> eq x y.
Proof.
inversion 1; inversion 1; econs; auto using A.le_antisym, B.le_antisym.
Qed.
Lemma le_trans : forall x y z : t, le x y -> le y z -> le x z.
Proof.
inversion 1; inversion 1; econs; eauto using A.le_trans, B.le_trans.
Qed.

Lemma eq_refl : forall x : t, eq x x.
Proof. destruct x; econs; auto using A.eq_refl, B.eq_refl. Qed.
Lemma eq_sym : forall x y : t, eq x y -> eq y x.
Proof. inversion 1; econs; auto using A.eq_sym, B.eq_sym. Qed.
Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
Proof.
inversion 1; inversion 1; econs; eauto using A.eq_trans, B.eq_trans.
Qed.

Definition le_dec (x y : t) : {le x y} + {~ le x y}.
refine
  ((if physical_eq x y as c return
       physical_eq x y = c -> {le x y} + {~ le x y} then fun Hc => left _
    else fun _ =>
           match x, y with
             | _, Top => left (le_top _)
             | Bot, _ => left (le_bot _)
             | Inl x', Inl y' =>
               match A.le_dec x' y' with
                 | left l => left (le_inl l)
                 | right _ => right _
               end
             | Inr x', Inr y' =>
               match B.le_dec x' y' with
                 | left l => left (le_inr l)
                 | right _ => right _
               end
             | _, _ => right _
           end) Logic.eq_refl); try (inversion 1; tauto).
+ apply physical_eq_prop in Hc; subst; apply le_refl; by apply eq_refl.
Qed.

Definition eq_dec (x y : t) : {eq x y} + {~ eq x y}.
refine
  ((if physical_eq x y as c return
       physical_eq x y = c -> {eq x y} + {~ eq x y} then fun Hc => left _
    else fun _ =>
           match x, y with
             | Top, Top => left eq_top
             | Bot, Bot => left eq_bot
             | Inl x', Inl y' =>
               match A.eq_dec x' y' with
                 | left l => left (eq_inl l)
                 | right _ => right _
               end
             | Inr x', Inr y' =>
               match B.eq_dec x' y' with
                 | left l => left (eq_inr l)
                 | right _ => right _
               end
             | _, _ => right _
           end) Logic.eq_refl); try (inversion 1; tauto).
+ apply physical_eq_prop in Hc; subst; by apply eq_refl.
Qed.

Definition top : t := Top.
Definition bot : t := Bot.
Lemma top_prop : forall x : t, le x top.
Proof. by econs. Qed.
Lemma bot_prop : forall x : t, le bot x.
Proof. by econs. Qed.

Definition join (x y : t) : t :=
  match x, y with
    | Top, _
    | _, Top => Top
    | Bot, a
    | a, Bot => a
    | Inl x', Inl y' => Inl (A.join x' y')
    | Inr x', Inr y' => Inr (B.join x' y')
    | _, _ => Top
  end.

Lemma join_left : forall (x y : t), le x (join x y).
Proof.
  i; unfold join ; destruct x, y
  ; try apply top_prop; try apply bot_prop
  ; try (apply le_refl; apply eq_refl)
  ; constructor; auto using A.join_left, B.join_left.
Qed.

Lemma join_right : forall (x y : t), le y (join x y).
Proof.
  i; unfold join ; destruct x, y
  ; try apply top_prop; try apply bot_prop
  ; try (apply le_refl; apply eq_refl)
  ; constructor; auto using A.join_right, B.join_right.
Qed.

Lemma join_lub : forall (x y u : t) (Hx : le x u) (Hy : le y u), le (join x y) u.
Proof.
  destruct x, y, u; intros H1 H2; unfold join
  ; try (apply le_refl; apply eq_refl)
  ; try (apply bot_prop); try (apply top_prop)
  ; try inversion H1; try inversion H2
  ; try (constructor; by auto using A.join_lub, B.join_lub).
Qed.

Definition meet (x y : t) : t :=
  match x, y with
    | Top, a
    | a, Top => a
    | Bot, _
    | _, Bot => Bot
    | Inl x', Inl y' => Inl (A.meet x' y')
    | Inr x', Inr y' => Inr (B.meet x' y')
    | _, _ => Bot
  end.

Lemma meet_left : forall (x y : t), le (meet x y) x.
Proof.
  intros. unfold meet.
  destruct x,y;
  try (apply le_refl;apply eq_refl);try (apply bot_prop);
  try (apply top_prop).
  apply le_inl; apply A.meet_left.
  apply le_inr; apply B.meet_left.
Qed.

Lemma meet_right : forall (x y : t), le (meet x y) y.
Proof.
  intros. unfold meet.
  destruct x,y; try (apply le_refl;apply eq_refl);try (apply bot_prop);
  try (apply top_prop).
  apply le_inl; apply A.meet_right.
  apply le_inr; apply B.meet_right.
Qed.

Lemma meet_glb : forall (x y l : t) (Hx : le l x) (Hy : le l y), le l (meet x y).
Proof.
  destruct x, y, l; intros H1 H2; unfold meet
  ; try (apply le_refl; apply eq_refl)
  ; try (apply bot_prop); try (apply top_prop)
  ; try inversion H1; try inversion H2
  ; try (constructor; by auto using A.meet_glb, B.meet_glb).
Qed.

Definition widen (x y : t) : t :=
  match x, y with
    | _, Top
    | Top, _ => Top
    | Bot, a
    | a, Bot => a
    | Inl a, Inl b => Inl (A.widen a b)
    | Inr a, Inr b => Inr (B.widen a b)
    | _, _ => Top
  end.

Definition narrow (x y : t) : t :=
  if structural_eq x y then x else
  match x, y with
    | Top, a => a
    | _, Bot => Bot
    | Inl a, Inl b => Inl (A.narrow a b)
    | Inr a, Inr b => Inr (B.narrow a b)
    | _, _ => invalid_arg sum_narrow_msg
  end.

Include JoinMeetProp.

End Sum.

(** * Sum for multiple lattices *)

Module SumKey2 (A:KEY) (B:KEY).
  Include SumKey A B.
End SumKey2.

Module SumKey3 (A:KEY) (B:KEY) (C:KEY).
  Module E2 := SumKey A B.
  Include SumKey E2 C.
End SumKey3.

Module SumKey4 (A:KEY) (B:KEY) (C:KEY) (D:KEY).
  Module E2 := SumKey A B.
  Module E3 := SumKey E2 C.
  Include SumKey E3 D.
End SumKey4.

Module SumKey5 (A:KEY) (B:KEY) (C:KEY) (D:KEY) (E:KEY).
  Module E2 := SumKey A B.
  Module E3 := SumKey E2 C.
  Module E4 := SumKey E3 D.
  Include SumKey E4 E.
End SumKey5.

Module Sum2 (A:LAT) (B:LAT).
  Include Sum A B.
End Sum2.

Module Sum3 (A:LAT) (B:LAT) (C:LAT).
  Module E2 := Sum A B.
  Include Sum E2 C.
End Sum3.

Module Sum4 (A:LAT) (B:LAT) (C:LAT) (D:LAT).
  Module E2 := Sum A B.
  Module E3 := Sum E2 C.
  Include Sum E3 D.
End Sum4.

Module Sum5 (A:LAT) (B:LAT) (C:LAT) (D:LAT) (E:LAT).
  Module E2 := Sum A B.
  Module E3 := Sum E2 C.
  Module E4 := Sum E3 D.
  Include Sum E4 E.
End Sum5.


(** Authors: Jianzhou Zhao. *)

Require Export Bang_Parametricity_Pre.
Require Import Program.

Module Type IParametricity.

(* ********************************************************************** *)
(** * Wf Relations *)

Definition wfr (r : rel) (T T' : typ) : Prop :=
  (wf_typ nil T) /\
  (wf_typ nil T').

Axiom wfr_inv : forall r T T',
  wfr r T T' ->
  (wf_typ nil T) /\
  (wf_typ nil T').

Axiom wfr_left_inv : forall t t' R,
  wfr R t t' -> wf_typ nil t.

Axiom wfr_right_inv : forall t t' R,
  wfr R t t' -> wf_typ nil t'.

(* ********************************************************************** *)
(** * Value Relations *)
Program Fixpoint F_related_values
    (t:typ) (rsubst:rho_subst)
    (dsubst dsubst':delta_subst) (v:exp) (v':exp) {measure typ_size t} : Prop :=
  match t with
  | typ_fvar X =>
  (*
       (v, v') \in R
       . |- v : dsubst(X)
       . |- v' : dsubst'(X)
    -------------------
       v ~ v' : X | (\rho, X->R)
  *)
    exists R,
    (binds X R rsubst) /\ (value v) /\ (value v') /\ (R v v')
  | typ_arrow t1 t2 =>
  (*
    v and v' are values
    . |- v : dsubst(t1->t2) . |- v' : dsubst'(t1->t2)
    \forall x x', . |- x : dsubst(t1)  . |- x' : dsubst'(t1)  (x ~~ x': t1 | \rho) -> v x ~~ v' x':t2 | \rho
   -----------------------------------------------------------------
          v ~ v': t1->t2 | \rho
  *)
    (value v) /\ (value v') /\
    (forall x x',
     typing nil nil x (apply_delta_subst_typ dsubst t1) ->
     typing nil nil x' (apply_delta_subst_typ dsubst' t1) ->
     (exists w, exists w',
      normalize x w /\ normalize x' w' /\
      F_related_values t1 rsubst dsubst dsubst' w w') ->
     (exists u, exists u',
      normalize (exp_app v x) u /\
      normalize (exp_app v' x') u' /\
      F_related_values t2 rsubst dsubst dsubst' u u')
    )
  | typ_all t1 =>
  (*
    v and v' are values
    . |- v : dsubst(A t1) . |- v' : dsubst'(A t1')
    \forall R \in t2 <-> t2. v[t2] ~~ v'[t2'] : t1 | \rho, U->R
   -----------------------------------------------------------------
          v ~ v': \/U. t1 | \rho
  *)
      (
      (value v) /\ (value v') /\
      (exists L,
         (forall (X:atom) t2 t2' R (Fr:X `notin` L),
         wfr R t2 t2' ->
          X `notin` ((dom rsubst) `union` (fv_tt t1)) ->
          (exists w, exists w',
          normalize (exp_tapp v t2) w /\
          normalize (exp_tapp v' t2') w' /\
          F_related_values (open_tt t1 X)
                           ([(X,R)]++rsubst)
                           ([(X,t2)]++dsubst)
                           ([(X,t2')]++dsubst')
                            w w')
        ))
      )
  | typ_bang t1 =>
    (value v) /\ (value v') /\
    (exists e1, exists e1',
      v = exp_bang e1 /\
      v' = exp_bang e1' /\
      (exists u1, exists u1',
       normalize e1 u1 /\
       normalize e1' u1' /\
       F_related_values t1 rsubst dsubst dsubst' u1 u1')
    )
  | typ_with t1 t2 =>
  (*
     . |-  <m1, m2> : dsubst(t1*t2)
     . |-  <m1', m2'> : dsubst'(t1*t2)
      m1 ~~ m1' : t1 | \rho
      m2 ~~ m2' : t2 | \rho
   -----------------------------------------------------------------
         <m1, m2> ~ <m1', m2'>: t1*t2 | \rho
  *)
    (value v) /\ (value v') /\
    (exists e1, exists e2, exists e1', exists e2',
      v = exp_apair e1 e2 /\
      v' = exp_apair e1' e2' /\
      (exists u1, exists u1',
       normalize e1 u1 /\
       normalize e1' u1' /\
       F_related_values t1 rsubst dsubst dsubst' u1 u1') /\
      (exists u2, exists u2',
       normalize e2 u2 /\
       normalize e2' u2' /\
       F_related_values t2 rsubst dsubst dsubst' u2 u2')
    )
  | _ => False
  end
  .
Obligation 1.
  simpl. omega.
Qed.
Next Obligation.
  rewrite <- Heq_t. simpl. omega.
Qed.
Next Obligation.
  simpl.
  assert (typ_size (open_tt t1 X) = typ_size t1). apply open_tt_typ_size_eq.
  omega.
Qed.
Next Obligation.
  simpl.  omega.
Qed.
Next Obligation.
  simpl.  omega.
Qed.
Next Obligation.
  split.
    intros t1 t2. unfold not. intro C. inversion C.
  split.
    intros t1. unfold not. intro C. inversion C.
  split.
    intros t1. unfold not. intro C. inversion C.
  split.
    intros t1 t2. unfold not. intro C. inversion C.
    intros X. unfold not. intro C. inversion C.
Qed.

(** * Term Relations *)
(*
   .| e : dsubst(t)    .| e' : dsubst'(t)
    e ->* v               e' ->* v'
    (v ~ v': t | \rho)
   -----------------------------------------------------------------
    e ~~ e': t | \rho
*)
Definition F_related_terms t rsubst (dsubst dsubst':delta_subst) e e': Prop:=
    exists v, exists v',
    typing nil nil e (apply_delta_subst_typ dsubst t) /\
    typing nil nil e' (apply_delta_subst_typ dsubst' t) /\
    normalize e v /\
    normalize e' v' /\
    F_related_values t rsubst dsubst dsubst' v v'
  .

(** * Subst Relations *)
Inductive F_related_subst : env -> lenv -> gamma_subst -> gamma_subst -> gamma_subst -> gamma_subst -> rho_subst -> delta_subst -> delta_subst -> Prop:=
  | F_related_subst_empty :
    (*
      gamma_nil ~ gamma_nil : gempty | rho_nil, delta_nil,  delta_nil
    *)
      F_related_subst nil nil gamma_nil gamma_nil gamma_nil gamma_nil rho_nil delta_nil delta_nil
  | F_related_subst_kind :
    (*
      gsubst ~ gsubst' : genv | rsubst, dsubst, dsubst'
      R \in t<->t'
     -----------------------------------------------------------------
      gsubst ~ gsubst' : genv | (rsubst, X->R), (dsubst, X->t), (dsubst', X->t')
    *)
    forall (E:env) (lE:lenv) (gsubst gsubst' lgsubst lgsubst':gamma_subst) (rsubst:rho_subst) (dsubst dsubst':delta_subst) X R t t',
      F_related_subst E lE gsubst gsubst' lgsubst lgsubst' rsubst dsubst dsubst'->
      X `notin` (fv_env E) `union` (fv_lenv lE) ->
      wfr R t t' ->
      F_related_subst ([(X, bind_kn)]++E) lE gsubst gsubst' lgsubst lgsubst'
                                   ([(X,R)]++rsubst) ([(X,t)]++dsubst) ([(X,t')]++dsubst')
  | F_related_subst_typ :
    (*
      gsubst ~ gsubst' : genv | rsubst, dsubst, dsubst'
      e ~ e' : t | rho_subst
     -----------------------------------------------------------------
      (gsubst, x->e) ~ (gsubst',x->e') : (genv, x:t) | rho_subst, dsubst, dsubst'
    *)
    forall (E:env)(lE:lenv)(gsubst gsubst' lgsubst lgsubst':gamma_subst) (e e':exp) (t:typ) (rsubst:rho_subst) (dsubst dsubst':delta_subst) (x:atom),
      F_related_subst E lE gsubst gsubst' lgsubst lgsubst' rsubst dsubst dsubst'->
      typing nil nil e (apply_delta_subst_typ dsubst t) ->
      typing nil nil e' (apply_delta_subst_typ dsubst' t) ->
      F_related_terms t rsubst dsubst dsubst' e e' ->
      x `notin` ((fv_env E) `union` (fv_lenv lE) `union` (fv_tt t)) ->
      wf_typ E t ->
      F_related_subst ([(x, bind_typ t)]++E) lE
                   ([(x, e)]++gsubst) ([(x, e')]++gsubst') lgsubst lgsubst' rsubst dsubst dsubst'
  | F_related_subst_ltyp :
    (*
      gsubst ~ gsubst' : genv | rsubst, dsubst, dsubst'
      e ~ e' : t | rho_subst
     -----------------------------------------------------------------
      (gsubst, x->e) ~ (gsubst',x->e') : (genv, x:t) | rho_subst, dsubst, dsubst'
    *)
    forall (E:env)(lE:lenv)(gsubst gsubst' lgsubst lgsubst':gamma_subst) (e e':exp) (t:typ) (rsubst:rho_subst) (dsubst dsubst':delta_subst) (x:atom),
      F_related_subst E lE gsubst gsubst' lgsubst lgsubst' rsubst dsubst dsubst'->
      typing nil nil e (apply_delta_subst_typ dsubst t) ->
      typing nil nil e' (apply_delta_subst_typ dsubst' t) ->
      F_related_terms t rsubst dsubst dsubst' e e' ->
      x `notin` ((fv_env E) `union` (fv_lenv lE) `union` (fv_tt t)) ->
      wf_typ E t ->
      F_related_subst E ([(x, lbind_typ t)]++lE)
                   gsubst gsubst' ([(x, e)]++lgsubst) ([(x, e')]++lgsubst') rsubst dsubst dsubst'
      .

Tactic Notation "F_related_subst_cases" tactic(first) tactic(c) :=
  first;
  [ c "F_related_subst_empty" |
    c "F_related_subst_kind" |
    c "F_related_subst_typ" |
    c "F_related_subst_ltyp" ].

(** * Relations Subst *)
Inductive F_Rsubst : env-> rho_subst-> delta_subst -> delta_subst -> Prop:=
  | F_Rsubst_empty :
    (*
      empty |- rho_nil \in delta_nil <-> delta_nil
    *)
      F_Rsubst nil rho_nil delta_nil delta_nil
  | F_Rsubst_rel :
    (*
      env |- rho_subst \in delta_subst <-> delta_subst'
      R \in t <-> t'
     -----------------------------------------------------------------
      env, X |- (rho_subst, X->R) \in (delta_subst, X->t) <-> (delta_subst', X->t')
    *)
    forall (E:env) (rsubst:rho_subst) (dsubst:delta_subst) (dsubst':delta_subst) R t t' X,
      F_Rsubst E rsubst dsubst dsubst' ->
      wfr R t t' ->
      X `notin` (fv_env E) ->
      F_Rsubst ([(X, bind_kn)]++E) ([(X, R)]++rsubst) ([(X, t)]++dsubst) ([(X, t')]++dsubst')
  | F_Rsubst_typ :
    (*
      env |- rho_subst \in delta_subst <-> delta_subst'
     -----------------------------------------------------------------
      env, x~:T |- rho_subst \in delta_subst <-> delta_subst'
    *)
    forall (E:env) (rsubst:rho_subst) (dsubst:delta_subst) (dsubst':delta_subst) x T,
      F_Rsubst E rsubst dsubst dsubst' ->
      wf_typ E T ->
      x `notin` (fv_env E) ->
      F_Rsubst ([(x, bind_typ T)]++E) rsubst dsubst dsubst'
      .

Tactic Notation "F_Rsubst_cases" tactic(first) tactic(c) :=
  first;
  [ c "F_Rsubst_empty" |
    c "F_Rsubst_rel" |
    c "F_Rsubst_typ" ].

(** * SystemF Relations *)
Definition F_Rel t rsubst (dsubst dsubst':delta_subst) v v' :=
   F_related_values t rsubst dsubst dsubst' v v'
  .

Hint Constructors F_related_subst F_Rsubst.

(* ********************************************************************** *)
(* Fvalue simplification *)
Axiom F_related_values_bvar_eq: forall i (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp),
  F_related_values (typ_bvar i) rsubst dsubst dsubst' v v' <-> False.

Axiom F_related_values_bvar_leq: forall i (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp),
  F_related_values (typ_bvar i) rsubst dsubst dsubst' v v' -> False.

Axiom F_related_values_bvar_req: forall i (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp),
  False ->
  F_related_values (typ_bvar i) rsubst dsubst dsubst' v v'.

Axiom F_related_values_fvar_eq: forall X (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp),
  F_related_values (typ_fvar X) rsubst dsubst dsubst' v v' <->
    exists R,
     (binds X R rsubst) /\ (value v) /\ (value v') /\ (R v v')
  .

Axiom F_related_values_fvar_leq: forall X  (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp),
  F_related_values (typ_fvar X) rsubst dsubst dsubst' v v' ->
    exists R,
      (binds X R rsubst) /\ (value v) /\ (value v') /\ (R v v')
  .

Axiom F_related_values_fvar_req: forall X  (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp),
  (exists R,
    (binds X R rsubst) /\ (value v) /\ (value v') /\ (R v v')) ->
  F_related_values (typ_fvar X) rsubst dsubst dsubst' v v'.

Axiom F_related_values_arrow_eq: forall (t1 t2:typ)  (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp),
  F_related_values (typ_arrow t1 t2) rsubst dsubst dsubst' v v'
  <->
  (
    (value v) /\ (value v') /\
    (forall x x',
     typing nil nil x (apply_delta_subst_typ dsubst t1) ->
     typing nil nil x' (apply_delta_subst_typ dsubst' t1) ->
     (exists w, exists w',
      normalize x w /\ normalize x' w' /\
      F_related_values t1 rsubst dsubst dsubst' w w') ->
     (exists u, exists u',
      normalize (exp_app v x) u /\
      normalize (exp_app v' x') u' /\
      F_related_values t2 rsubst dsubst dsubst' u u')
    )
  )
   .

Axiom F_related_values_arrow_leq: forall (t1 t2:typ) (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp),
  F_related_values (typ_arrow t1 t2) rsubst dsubst dsubst' v v'
  ->
  (
    (value v) /\ (value v') /\
    (forall x x',
     typing nil nil x (apply_delta_subst_typ dsubst t1) ->
     typing nil nil x' (apply_delta_subst_typ dsubst' t1) ->
     (exists w, exists w',
      normalize x w /\ normalize x' w' /\
      F_related_values t1 rsubst dsubst dsubst' w w') ->
     (exists u, exists u',
      normalize (exp_app v x) u /\
      normalize (exp_app v' x') u' /\
      F_related_values t2 rsubst dsubst dsubst' u u')
    )
  )
   .

Axiom F_related_values_arrow_req: forall (t1 t2:typ) (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp),
  (
    (value v) /\ (value v') /\
    (forall x x',
     typing nil nil x (apply_delta_subst_typ dsubst t1) ->
     typing nil nil x' (apply_delta_subst_typ dsubst' t1) ->
     (exists w, exists w',
      normalize x w /\ normalize x' w' /\
      F_related_values t1 rsubst dsubst dsubst' w w') ->
     (exists u, exists u',
      normalize (exp_app v x) u /\
      normalize (exp_app v' x') u' /\
      F_related_values t2 rsubst dsubst dsubst' u u')
    )
  ) ->
  F_related_values (typ_arrow t1 t2) rsubst dsubst dsubst' v v'
   .

Axiom F_related_values_all_eq: forall (t1:typ) (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp),
  F_related_values (typ_all t1) rsubst dsubst dsubst' v v'
  <->
      (
      (value v) /\ (value v') /\
      (exists L,
         (forall (X:atom) t2 t2' R (Fr:X `notin` L),
         wfr R t2 t2' ->
          X `notin` ((dom rsubst) `union` (fv_tt t1)) ->
          (exists w, exists w',
          normalize (exp_tapp v t2) w /\
          normalize (exp_tapp v' t2') w' /\
          F_related_values (open_tt t1 X)
                           ([(X, R)]++rsubst)
                           ([(X, t2)]++dsubst)
                           ([(X, t2')]++dsubst')
                            w w')
        ))
      )
  .

Axiom F_related_values_all_leq: forall (t1:typ) (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp),
  F_related_values (typ_all t1) rsubst dsubst dsubst' v v'
  ->
      (
      (value v) /\ (value v') /\
      (exists L,
         (forall (X:atom) t2 t2' R (Fr:X `notin` L),
         wfr R t2 t2' ->
          X `notin` ((dom rsubst) `union` (fv_tt t1)) ->
          (exists w, exists w',
          normalize (exp_tapp v t2) w /\
          normalize (exp_tapp v' t2') w' /\
          F_related_values (open_tt t1 X)
                           ([(X, R)]++rsubst)
                           ([(X, t2)]++dsubst)
                           ([(X, t2')]++dsubst')
                            w w')
        ))
      )
  .

Axiom F_related_values_all_req: forall (t1:typ) (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp),
      (
      (value v) /\ (value v') /\
      (exists L,
         (forall (X:atom) t2 t2' R (Fr:X `notin` L),
         wfr R t2 t2' ->
          X `notin` ((dom rsubst) `union` (fv_tt t1)) ->
          (exists w, exists w',
          normalize (exp_tapp v t2) w /\
          normalize (exp_tapp v' t2') w' /\
          F_related_values (open_tt t1 X)
                           ([(X, R)]++rsubst)
                           ([(X, t2)]++dsubst)
                           ([(X, t2')]++dsubst')
                            w w')
        ))
      )
  ->
  F_related_values (typ_all t1) rsubst dsubst dsubst' v v'
  .

Axiom F_related_values_bang_eq: forall (t1:typ) (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp),
  F_related_values (typ_bang t1) rsubst dsubst dsubst' v v'
  <->
    (value v) /\ (value v') /\
    (exists e1, exists e1',
      v = exp_bang e1 /\
      v' = exp_bang e1' /\
      (exists u1, exists u1',
       normalize e1 u1 /\
       normalize e1' u1' /\
       F_related_values t1 rsubst dsubst dsubst' u1 u1')
    )
   .

Axiom F_related_values_bang_leq: forall (t1:typ) (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp),
  F_related_values (typ_bang t1) rsubst dsubst dsubst' v v'
  ->
    (value v) /\ (value v') /\
    (exists e1, exists e1',
      v = exp_bang e1 /\
      v' = exp_bang e1' /\
      (exists u1, exists u1',
       normalize e1 u1 /\
       normalize e1' u1' /\
       F_related_values t1 rsubst dsubst dsubst' u1 u1')
    )
   .

Axiom F_related_values_bang_req: forall (t1:typ) (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp),
    (value v) /\ (value v') /\
    (exists e1, exists e1',
      v = exp_bang e1 /\
      v' = exp_bang e1' /\
      (exists u1, exists u1',
       normalize e1 u1 /\
       normalize e1' u1' /\
       F_related_values t1 rsubst dsubst dsubst' u1 u1')
    )
  ->
  F_related_values (typ_bang t1) rsubst dsubst dsubst' v v'
   .

Axiom F_related_values_with_eq: forall (t1 t2:typ) (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp),
  F_related_values (typ_with t1 t2) rsubst dsubst dsubst' v v'
  <->
    (value v) /\ (value v') /\
    (exists e1, exists e2, exists e1', exists e2',
      v = exp_apair e1 e2 /\
      v' = exp_apair e1' e2' /\
      (exists u1, exists u1',
       normalize e1 u1 /\
       normalize e1' u1' /\
       F_related_values t1 rsubst dsubst dsubst' u1 u1') /\
      (exists u2, exists u2',
       normalize e2 u2 /\
       normalize e2' u2' /\
       F_related_values t2 rsubst dsubst dsubst' u2 u2')
    )
   .

Axiom F_related_values_with_leq: forall (t1 t2:typ) (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp),
  F_related_values (typ_with t1 t2) rsubst dsubst dsubst' v v'
  ->
    (value v) /\ (value v') /\
    (exists e1, exists e2, exists e1', exists e2',
      v = exp_apair e1 e2 /\
      v' = exp_apair e1' e2' /\
      (exists u1, exists u1',
       normalize e1 u1 /\
       normalize e1' u1' /\
       F_related_values t1 rsubst dsubst dsubst' u1 u1') /\
      (exists u2, exists u2',
       normalize e2 u2 /\
       normalize e2' u2' /\
       F_related_values t2 rsubst dsubst dsubst' u2 u2')
    )
   .

Axiom F_related_values_with_req: forall (t1 t2:typ) (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp),
    (value v) /\ (value v') /\
    (exists e1, exists e2, exists e1', exists e2',
      v = exp_apair e1 e2 /\
      v' = exp_apair e1' e2' /\
      (exists u1, exists u1',
       normalize e1 u1 /\
       normalize e1' u1' /\
       F_related_values t1 rsubst dsubst dsubst' u1 u1') /\
      (exists u2, exists u2',
       normalize e2 u2 /\
       normalize e2' u2' /\
       F_related_values t2 rsubst dsubst dsubst' u2 u2')
    )
  ->
  F_related_values (typ_with t1 t2) rsubst dsubst dsubst' v v'
   .

(* ********************************************************************** *)
(** * Inversion *)

Axiom F_related_values_inversion: forall t v v' rsubst dsubst dsubst',
  F_related_values t rsubst dsubst dsubst' v v' ->
  ((value v)* (value v'))%type.

Axiom F_Rsubst__wf_subst:
  forall (E:env) (rsubst:rho_subst) (dsubst:delta_subst) (dsubst':delta_subst),
  F_Rsubst E rsubst dsubst dsubst'  ->
  ((wf_delta_subst E dsubst) * (wf_delta_subst E dsubst') * (wf_rho_subst E rsubst))%type.

Axiom Frel_inversion: forall t rsubst dsubst dsubst' v v',
  F_Rel t rsubst dsubst dsubst' v v' ->
  ((value v)* (value v'))%type.

Axiom F_related_subst__inversion:
  forall (E:env) (lE:lenv) (rsubst:rho_subst) (dsubst:delta_subst) (dsubst':delta_subst) gsubst gsubst' lgsubst lgsubst',
  F_related_subst E lE gsubst gsubst' lgsubst lgsubst' rsubst dsubst dsubst' ->
  ((wf_delta_subst E dsubst) * (wf_delta_subst E dsubst') *
   (wf_lgamma_subst E lE dsubst gsubst lgsubst)* (wf_lgamma_subst E lE dsubst' gsubst' lgsubst') *
   (wf_rho_subst E rsubst) * (wf_env E))%type.

(* **************************************** *)
(** * Weaken and Stronger of SystemF Relations *)

Axiom Frel_weaken:  forall t E E' v v' rsubst rsubst' dsubst dsubst' dsubst0 dsubst'0 X R t2 t2',
  ((F_related_values t (rsubst'++rsubst) (dsubst0++dsubst) (dsubst'0++dsubst') v v' ->
  ddom_env E [=] dom dsubst ->
  ddom_env E [=] dom dsubst' ->
  ddom_env E' [=] dom dsubst0 ->
  ddom_env E' [=] dom dsubst'0 ->
  ddom_env E [=] dom rsubst ->
  ddom_env E' [=] dom rsubst' ->
  X `notin` (fv_env E `union` fv_env E' `union` (fv_tt t))->
  wfr R t2 t2' ->
  wf_rho_subst (E'++E) (rsubst'++rsubst) ->
  wf_delta_subst (E'++E) (dsubst0++dsubst) ->
  wf_delta_subst (E'++E) (dsubst'0++dsubst') ->
  F_related_values t (rsubst'++[(X, R)]++rsubst) (dsubst0++[(X, t2)]++dsubst) (dsubst'0++[(X, t2')]++dsubst') v v' ))
  .

Axiom Frel_weaken_head:  forall t E v v' rsubst dsubst dsubst' X R t2 t2',
  ((F_related_values t rsubst dsubst dsubst' v v' ->
  ddom_env E [=] dom dsubst ->
  ddom_env E [=] dom dsubst' ->
  ddom_env E [=] dom rsubst ->
  X `notin` (fv_env E `union` (fv_tt t))->
  wfr R t2 t2' ->
  wf_rho_subst E rsubst ->
  wf_delta_subst E dsubst ->
  wf_delta_subst E dsubst' ->
  F_related_values t ([(X, R)]++rsubst) ([(X, t2)]++dsubst) ([(X, t2')]++dsubst') v v' ))
  .

Axiom Frel_stronger:  forall t E E' v v' rsubst rsubst' dsubst dsubst' dsubst0 dsubst'0 X R t2 t2',
  F_related_values t (rsubst'++[(X, R)]++rsubst) (dsubst0++[(X, t2)]++dsubst) (dsubst'0++[(X, t2')]++dsubst') v v' ->
  ddom_env E [=] dom dsubst ->
  ddom_env E [=] dom dsubst' ->
  ddom_env E' [=] dom dsubst0 ->
  ddom_env E' [=] dom dsubst'0 ->
  ddom_env E [=] dom rsubst ->
  ddom_env E' [=] dom rsubst' ->
  X `notin` (fv_env E `union` fv_env E' `union` (fv_tt t))->
  wfr R t2 t2' ->
  wf_rho_subst (E'++[(X, bind_kn)]++E) (rsubst'++[(X, R)]++rsubst) ->
  wf_delta_subst (E'++[(X, bind_kn)]++E) (dsubst0++[(X, t2)]++dsubst) ->
  wf_delta_subst (E'++[(X, bind_kn)]++E) (dsubst'0++[(X, t2')]++dsubst') ->
  F_related_values t (rsubst'++rsubst) (dsubst0++dsubst) (dsubst'0++dsubst') v v'
  .

Axiom bindsgE__bindsgsubst: forall E lE gsubst gsubst' lgsubst lgsubst' rsubst dsubst dsubst' x T,
    F_related_subst E lE gsubst gsubst' lgsubst lgsubst' rsubst dsubst dsubst' ->
    binds x (bind_typ T) E ->
    wf_typ E T ->
    x `notin` dom lgsubst /\ x `notin` dom lgsubst' /\
    (exists e, exists e',
                ((binds x (e) gsubst)
                *(binds x (e') gsubst')
                *(typing nil nil e (apply_delta_subst_typ dsubst T))*(typing nil nil e' (apply_delta_subst_typ dsubst' T))
                *(F_related_terms T rsubst dsubst dsubst' e e'))%type)
    .

Axiom lbindsgE__lbindsgsubst: forall E lE gsubst gsubst' lgsubst lgsubst' rsubst dsubst dsubst' x T,
    F_related_subst E lE gsubst gsubst' lgsubst lgsubst' rsubst dsubst dsubst' ->
    binds x (lbind_typ T) lE ->
    wf_typ E T ->
    x `notin` dom gsubst /\ x `notin` dom gsubst' /\
    (exists e, exists e',
                ((binds x (e) lgsubst)
                *(binds x (e') lgsubst')
                *(typing nil nil e (apply_delta_subst_typ dsubst T))*(typing nil nil e' (apply_delta_subst_typ dsubst' T))
                *(F_related_terms T rsubst dsubst dsubst' e e'))%type)
    .

(*******************************************************************************)
(** subst *)

Definition F_Rel__R (t:typ) (E:env) (rsubst:rho_subst) dsubst dsubst' (R:rel) :=
  wf_delta_subst E dsubst /\  wf_delta_subst E dsubst' /\  wf_rho_subst E rsubst /\
  (forall v v',
    ((F_Rel t rsubst dsubst dsubst' v v' -> R v v')
   * (R v v'->F_Rel t rsubst dsubst dsubst' v v')) % type)
  .

Axiom F_Rel__R__wfr: forall (E:env) (t:typ) (rsubst:rho_subst) dsubst dsubst' (R:rel),
  F_Rel__R t E rsubst dsubst dsubst' R ->
  wf_typ E t ->
  wfr R (apply_delta_subst_typ dsubst t) (apply_delta_subst_typ dsubst' t).

Axiom parametricity_subst_value : forall t E E' e e' rsubst rsubst' dsubst dsubst' dsubst0 dsubst'0 X R t2 k,
  wf_typ (E'++[(X, bind_kn)]++E) (open_tt_rec k (typ_fvar X) t) ->
  wf_typ (E'++E) (open_tt_rec k t2 t) ->
  wf_typ (E'++E) t2 ->
  F_Rel__R t2 (E'++E) (rsubst'++rsubst) (dsubst0++dsubst) (dsubst'0++dsubst') R ->
  X `notin` (fv_env E `union` fv_env E' `union` (fv_tt t) `union` (fv_te e) `union` (fv_te e'))->
  ddom_env E [=] dom dsubst ->
  ddom_env E [=] dom dsubst' ->
  ddom_env E' [=] dom dsubst0 ->
  ddom_env E' [=] dom dsubst'0 ->
  ddom_env E [=] dom rsubst ->
  ddom_env E' [=] dom rsubst' ->
  (F_related_values (open_tt_rec k (typ_fvar X) t) (rsubst'++[(X, R)]++rsubst ) (dsubst0++[(X, (apply_delta_subst_typ (dsubst0++dsubst) t2))]++dsubst) (dsubst'0++[(X,(apply_delta_subst_typ (dsubst'0++dsubst') t2))]++dsubst') e e' ->
  wf_rho_subst (E'++[(X, bind_kn)]++E) (rsubst'++[(X, R)]++rsubst) ->
  wf_delta_subst (E'++[(X, bind_kn)]++E) (dsubst0++[(X, (apply_delta_subst_typ (dsubst0++dsubst) t2))]++dsubst) ->
  wf_delta_subst (E'++[(X, bind_kn)]++E) (dsubst'0++[(X, (apply_delta_subst_typ (dsubst'0++dsubst') t2))]++dsubst') ->
  F_related_values (open_tt_rec k t2 t) (rsubst'++rsubst) (dsubst0++dsubst) (dsubst'0++dsubst') e e')
  .

(*******************************************************************************)
(** F_related_subst_split *)

Axiom F_related_subst_split: forall E lE lE1 lE2 dsubst dsubst' gsubst gsubst' lgsubst lgsubst' rsubst,
   F_related_subst E lE gsubst gsubst' lgsubst lgsubst' rsubst dsubst dsubst' ->
   lenv_split E lE1 lE2 lE ->
   exists lgsubst1, exists lgsubst1', exists lgsubst2, exists lgsubst2',
     lgamma_subst_split E lE dsubst gsubst lgsubst1 lgsubst2 lgsubst /\
     lgamma_subst_split E lE dsubst' gsubst' lgsubst1' lgsubst2' lgsubst' /\
     F_related_subst E lE1 gsubst gsubst' lgsubst1 lgsubst1' rsubst dsubst dsubst' /\
     F_related_subst E lE2 gsubst gsubst' lgsubst2 lgsubst2' rsubst dsubst dsubst'.

(*******************************************************************************)
(** parametricity *)

Axiom parametricity: forall E lE e t dsubst dsubst' gsubst gsubst' lgsubst lgsubst' rsubst,
   typing E lE e t ->
   F_related_subst E lE gsubst gsubst' lgsubst lgsubst' rsubst dsubst dsubst' ->
   F_Rsubst E rsubst dsubst dsubst'->
   F_related_terms t rsubst dsubst dsubst'
                                 (apply_delta_subst dsubst (apply_gamma_subst gsubst (apply_gamma_subst lgsubst e)))
                                 (apply_delta_subst dsubst' (apply_gamma_subst gsubst' (apply_gamma_subst lgsubst' e)))
   .

End IParametricity.

(*
*** Local Variables: ***
*** coq-prog-name: "coqtop" ***
*** coq-prog-args: ("-emacs-U" "-I" "../../../metatheory" "-I" "../Bang") ***
*** End: ***
 *)


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

 This tests the formal syntax, pg. 57.
 But it also tests the contexts for historical reasons.

*)

Set Implicit Arguments.
Require Export LanguageModuleDef.
Require Import TestUtilities.

Check A : Kappa.
Check B : Kappa.

Check (TV.var 0) : TVar.

Check witnesschanges : Phi.
Check aliases         : Phi.

Check (ftvar (TV.var 0)) : Tau.
Check (btvar 0) : Tau.
Check cint : Tau.
Check cross cint cint : Tau.
Check arrow cint cint : Tau.
Check ptype cint : Tau.
Check utype A cint : Tau.
Check etype aliases B cint : Tau.

Check EV.var 0 : EVar.

Check e_s  (i_e (i_i 0)) : St.
Check retn (i_e (i_i 0)) : St.
Check seq (e_s  (i_e (i_i 0))) (retn (i_e (i_i 0))) : St.
Check if_s (i_e (i_i 0)) (e_s  (i_e (i_i 0))) (retn (i_e (i_i 0))) : St.
Check while (i_e (i_i 0)) (retn (i_e (i_i 0))) : St.
Check letx  (i_e (i_i 0)) (retn (p_e (bevar 0) [])) : St.
Check open (i_e (i_i 0)) (retn (p_e fx [])) : St.
Check openstar (i_e (i_i 0)) (retn (p_e fx [])) : St.

Example NumValue : Value (i_e (i_i 0)).
Proof.
  apply IIsAValue.
Qed.

(* Bug 1, no amp in source. *)
Example AmpValue :
  Value (amp (p_e fx [(i_pe one_pe)])).
Proof.
  apply AmpIsAValue.
Qed.

(* 2 bugs found, extra variable in quantification. *)
Example FunctionValue :
  Value (f_e (dfun cint cint (retn (p_e b0 [])))).
Proof.
  apply DfunIsAValue.
Qed.

Example PolymorphicFunctionValue :
  Value (f_e (ufun A
                   (dfun cint cint (retn (p_e b0 []))))).
Proof.
  apply UfunIsAValue.
Qed.

Example NotInDomHnil :
  H.map H.dot (EV.var 0)  = None.
Proof.
  reflexivity.
Qed.

Example NotInDomHsingle :
  H.map H.dot (EV.var 0)  = None.
Proof.
  reflexivity.
Qed.

Example NotInDomHdifferent :
  H.map (H.ctxt x v0 H.dot) y = None.
Proof.
  reflexivity.
Qed.

Example NotInDomHsecond :
  H.map (H.ctxt x v0 (H.ctxt z v0 H.dot)) y = None.
Proof.
  reflexivity.
Qed.

Example NotInDomDnil :
  D.map D.dot (TV.var 0) = None.
Proof.
  reflexivity.
Qed.

Example NotInDomDsingle :
  D.map (D.ctxt alpha A D.dot) alpha = Some A.
Proof.
  reflexivity.
Qed.

Example NotInDomDdifferent :
   D.map (D.ctxt alpha B D.dot) beta = None.
Proof.
  reflexivity.
Qed.

Example NotInDomDsecond :
   D.map (D.ctxt alpha A (D.ctxt gamma B D.dot)) beta = None.
Proof.
  reflexivity.
Qed.

(* TODO test setH. *)

Example deleteH_test_nil :
  H.delete H.dot x = H.dot.
Proof.
  reflexivity.
Qed.

Example deleteH_test_x :
  H.delete (H.ctxt x (i_e (i_i 0)) H.dot) x = H.dot.
Proof.
  reflexivity.
Qed.

Example delete_test_xy :
  H.delete (H.ctxt y (i_e (i_i 0)) (H.ctxt x (i_e (i_i 0)) H.dot)) x =
            (H.ctxt y (i_e (i_i 0)) H.dot).
Proof.
  reflexivity.
Qed.

Example delete_test_yx :
  H.delete (H.ctxt y (i_e (i_i 0)) (H.ctxt x (i_e (i_i 0)) H.dot)) y =
            (H.ctxt x (i_e (i_i 0)) H.dot).
Proof.
 reflexivity.
Qed.

Example delete_test_z :
  H.delete (H.ctxt y (i_e (i_i 0)) (H.ctxt x (i_e (i_i 0)) H.dot)) z =
            (H.ctxt y (i_e (i_i 0)) (H.ctxt x (i_e (i_i 0)) H.dot)).
Proof.
 reflexivity.
Qed.

Example DMadd_nil :
  D.add D.dot alpha A = (D.ctxt alpha A D.dot).
Proof.
  reflexivity.
Qed.

Example DMadd_exists :
  D.add (D.ctxt alpha B D.dot) alpha A = (D.ctxt alpha A D.dot).
Proof.
  reflexivity.
Qed.

Example DMadd_add_to_end :
  D.add (D.ctxt alpha B D.dot) beta A = (D.ctxt alpha B (D.ctxt beta A D.dot)).
Proof.
  reflexivity.
Qed.

Example DMadd_overwrite_at_end :
  D.add (D.ctxt alpha B (D.ctxt beta B D.dot)) beta A =
  (D.ctxt alpha B (D.ctxt beta A D.dot)).
Proof.
  reflexivity.
Qed.

Example DMadd_overwrite_at_start :
  D.add (D.ctxt alpha B (D.ctxt beta B D.dot)) alpha A =
         (D.ctxt alpha A (D.ctxt beta B D.dot)).
Proof.
  reflexivity.
Qed.

Example GMmapx :
  G.map (G.ctxt x tau G.dot) x = Some tau.
Proof.
  reflexivity.
Qed.

Example GMmapyx :
  G.map (G.ctxt y tau (G.ctxt x tau' G.dot)) x = Some tau'.
Proof.
  reflexivity.
Qed.

Example NotInDomGnil :
  G.map G.dot (EV.var 0) = None.
Proof.
  reflexivity.
Qed.

Example NotInDomGsingle :
  G.map (G.ctxt x tau G.dot) x = Some tau.
Proof.
  reflexivity.
Qed.

Example NotInDomGdifferent :
   G.map  (G.ctxt x tau G.dot) y = None.
Proof.
  reflexivity.
Qed.

Example NotInDomGsecond :
  G.map (G.ctxt x tau (G.ctxt z tau' G.dot)) y = None.
Proof.
  reflexivity.
Qed.

Example getUnil :
  forall (tau : Tau),
    ~G.map G.dot x = Some tau.
Proof.
  intros.
  compute.
  intros.
  inversion H.
Qed.

Example path_eq:
  Path.eqb [] [] = true.
Proof.
  reflexivity.
Qed.

Example getUx :
  U.map (U.ctxt (x, p0) tau U.dot) (x,p0) = Some tau.
Proof.
  compute.
  constructor.
Qed.

(* Bug 6 in defintion x <>y \/ [] = nil. *)
Example UMmapyx :
  U.map (U.ctxt (y,nil) tau (U.ctxt (x, nil) tau' U.dot)) (x,[]) = Some tau'.
Proof.
  reflexivity.
Qed.


From stdpp Require Import countable numbers gmap.
From iris.prelude Require Export prelude.
From iris.prelude Require Import options.

Record loc := Loc { loc_car : Z }.

Add Printing Constructor loc.

Global Instance loc_eq_decision : EqDecision loc.
Proof. solve_decision. Defined.

Global Instance loc_inhabited : Inhabited loc := populate {|loc_car := 0 |}.

Global Instance loc_countable : Countable loc.
Proof. by apply (inj_countable' loc_car Loc); intros []. Defined.

Program Instance loc_infinite : Infinite loc :=
  inj_infinite (λ p, {| loc_car := p |}) (λ l, Some (loc_car l)) _.
Next Obligation. done. Qed.

Definition loc_add (l : loc) (off : Z) : loc :=
  {| loc_car := loc_car l + off|}.

Notation "l +ₗ off" :=
  (loc_add l off) (at level 50, left associativity) : stdpp_scope.

Lemma loc_add_assoc l i j : l +ₗ i +ₗ j = l +ₗ (i + j).
Proof. destruct l; rewrite /loc_add /=; f_equal; lia. Qed.

Lemma loc_add_0 l : l +ₗ 0 = l.
Proof. destruct l; rewrite /loc_add /=; f_equal; lia. Qed.

Global Instance loc_add_inj l : Inj eq eq (loc_add l).
Proof. destruct l; rewrite /Inj /loc_add /=; intros; simplify_eq; lia. Qed.

Definition fresh_locs (ls : gset loc) : loc :=
  {| loc_car := set_fold (λ k r, (1 + loc_car k) `max` r)%Z 1%Z ls |}.

Lemma fresh_locs_fresh ls i :
  (0 ≤ i)%Z → fresh_locs ls +ₗ i ∉ ls.
Proof.
  intros Hi. cut (∀ l, l ∈ ls → loc_car l < loc_car (fresh_locs ls) + i)%Z.
  { intros help Hf%help. simpl in *. lia. }
  apply (set_fold_ind_L (λ r ls, ∀ l, l ∈ ls → (loc_car l < r + i)%Z));
    set_solver by eauto with lia.
Qed.

Global Opaque fresh_locs.


(* begin hide *)
Require Import F.
Require Import names.
Require Import subst.
Require Import basic.

Lemma typ_term_open_term_open_comm : forall t1 x T n m,
  open_t n (trm_fvar x) (open_tT m T t1) = open_tT m T (open_t n (trm_fvar x) t1).
Proof.
  induction t1 as [r | r | A t IH | t IH | t IH1 t' IH2 | t IH A | ];
    intros t2 T n m; simpl; auto; try apply_ccn.

  destruct A; simpl; try (rewrite -> IH; auto).

  rewrite -> IH; auto.

  rewrite -> IH1. rewrite -> IH2. auto.

  rewrite -> IH; auto.
Qed.

Lemma lc_open_tT : forall t,
  lc t ->
  forall n T,
    lc_T T ->
    lc (open_tT n T t).
Proof.  admit. Qed.

Lemma step_lc : forall t t', lc t -> t ~> t' -> lc t'.
Proof.
  intros t t' Hlc. generalize t'. clear - Hlc.
  induction Hlc; intros t' H2.

  invert_typing H2.

  invert_typing H2. apply lc_lam with (L:=L++L0); auto. intros.
  apply H1 with (x:=x); auto. destruct_nin.
  apply_hyp (H7 x H4) H5a. destruct H5a. destruct_conj. subst.
  rewrite -> close_open_id; auto.
  apply H1 with (x:=x); auto. auto.

  invert_typing H2. auto.

  invert_typing H2.
  invert_typing Hlc1.
  assert (~ In (pick_fresh (L++(FV_t t0)++(FV_t t2))) L).
  auto.
  apply_hyp (H5 (pick_fresh (L++(FV_t t0)++(FV_t t2))) H) H5a.

  apply lc_open_inst with (x:=pick_fresh (L ++ FV_t t0 ++ FV_t t2)) (L:=L); auto.

  apply lc_app; eauto.
  apply lc_app; eauto.

  invert_typing H2.  apply lc_open_tT; auto.

  auto. invert_typing H2.
Qed.
(* end hide *)
(** At this point we can now define the church-encoding of pairs.   The following defines the
    constructor for pairs.
  *)

(* Church-Encoding of pairs in system F. *)
Definition pair_cons := trm_Lam (trm_Lam (trm_lam (typ_bvar 1)
  (trm_lam (typ_bvar 0) (trm_Lam (trm_lam (typ_arrow (typ_bvar 2) (typ_arrow (typ_bvar 1) (typ_bvar 0)))
    ((trm_app (trm_app (trm_bvar 0) (trm_bvar 2)) (trm_bvar 1)))))))).

(** This is a little hard to read so lets take a look at this in mathematical notation.
    \( \Lambda X.\Lambda Y.\lambda x:X.\lambda y:Y.\Lambda Z.\lambda z:X \rightarrow (Y \rightarrow Z).(z\,x)\,y. \)
    Here the variables \(x\) and \(y\) are the data we are packaging up in the pair.  The variable \(z\)
    is used to project out the data of the pair. Next we define the type of [pair_cons].
  *)

Definition pair_cons_type := typ_forall (typ_forall (typ_arrow (typ_bvar 1) (typ_arrow (typ_bvar 0)
   (typ_forall (typ_arrow (typ_arrow (typ_bvar 2) (typ_arrow (typ_bvar 1) (typ_bvar 0))) (typ_bvar 0)))))).

(** In mathematical notation this looks like the following:
    \(\forall X.\forall Y.X \rightarrow (Y \rightarrow \forall Z.((X \rightarrow (Y \rightarrow Z)) \rightarrow Z))\).
    The previous definitions are how we encode church-style pairs in system F.  We define two convince definitions which
    will allow us to easily construct pairs.  The following is the definition of a pair given two terms [a:A] and [b:B].
  *)

Definition pair (A B:typ) (a b:trm) := trm_app (trm_app (trm_tapp (trm_tapp pair_cons A) B) a) b.

(** The following is the type of [pair]. *)

Definition pair_type A B := (typ_forall (typ_arrow (typ_arrow A (typ_arrow B (typ_bvar 0))) (typ_bvar 0))).

(** We need to be sure these are the correct definitions so we first show that [pair_cons] has the type [pair_cons_type]
    and that [pair] has the type [pair_type]. We omit proofs for brevity. *)
(* begin hide *)
Lemma open_T_id : forall A,
  lc_T A -> forall n B, open_T n B A = A.
Proof.
  induction 1; intros; simpl; auto.

  rewrite -> IHlc_T1. rewrite IHlc_T2. auto.

  (* Apply Hyp. H0 and commute the opens to obtain *
   * an equation between open_T (S n) B t and t.   *)
  admit.
Qed.

Lemma typing_lc : forall G a A, G :> a ; A -> lc a /\ lc_T A.
Proof. admit. Qed.
Hint Resolve typing_lc.
Lemma open_tT_id : forall n A a, lc a -> open_tT n A a = a.
Proof. admit. Qed.
Hint Rewrite open_id open_tT_id open_T_id : open_rw_db.

Ltac SNIN_C_Hyp :=
  match goal with
    | [H : ~In ?x _ |- _] =>
      match goal with
        | [H' : ~In x (x::_) |- _] =>
          contradiction H'; auto using in_eq
      end
  end.
Hint Extern 1  =>
  SNIN_C_Hyp.
Ltac SNIN_goal :=
  match goal with
    | [ |- ~ In ?x _] =>
      let H := fresh in
        simpl; unfold not; intros H;
          let H1 := fresh H in
            let H2 := fresh H in
              destruct H as [H1 | H2];
                [subst | destruct H2; subst]; auto
  end.
Hint Extern 1 (~In _ _) => SNIN_goal.
Ltac SC_Ok :=
  match goal with
    | [ |- Ok (_ :: nil) ] =>
      idtac "SC_OK: Need to write this goal."
    | [ |- Ok (_ :: _ :: nil) ] =>
      idtac "SC_OK: Need to write this goal."
    | [ |- Ok (_ :: _ :: _ :: nil) ] =>
      repeat apply Ok_ex; auto; simpl dom_t
    | [ |- Ok (_ :: _ :: _ :: _ :: nil) ] =>
      idtac "SC_OK: Need to write this goal."
    | [ |- Ok (_ :: _ :: _ :: _ :: _ :: nil) ] =>
      idtac "SC_OK: Need to write this goal."
    | [ |- Ok (_ :: _ :: _ :: _ :: _ :: _ :: nil) ] =>
      idtac "SC_OK: Need to write this goal."
  end.
Hint Extern 1 (Ok (_::nil)) => SC_Ok.

Hint Extern 1 (In _ _) =>
  match goal with
    | [ |- In ?x _] =>
      match goal with
        | [ |- In x (_ :: x :: _ :: nil)] =>
          simpl; apply or_intror; apply or_introl
        | [ |- In x (_ :: _ :: x :: nil)] =>
          simpl; apply or_intror; apply or_intror; apply or_introl
        | [ |- In x (_ :: x :: nil) ] =>
          simpl; apply or_intror; apply or_introl
      end; auto
  end.

Ltac typing_apply_var :=
  match goal with
    | [ |- _ :> trm_fvar ?x ; ?T ] =>
      apply T_Var; auto using in_eq
  end.
Hint Extern 1 (_ :> trm_fvar _ ; _) => (typing_apply_var).

Ltac roundup_names :=
  let rec roundup L :=
    match goal with
      | H: nat |- _ =>
        let name := constr:H in
          match L with
            | nil => roundup (name::nil)
            | context [name] => fail 1
            | _ => roundup (name::L)
          end
      | _ => L
    end
    in let L := roundup (nil:list nat) in eval simpl in L.
Ltac inject_names L :=
  let names := roundup_names in
    remember names as L.

Ltac typing_apply_TLam :=
  match goal with
    | [|- _ :> trm_Lam _; _] =>
      let names := roundup_names in
        apply T_TLam with (L:=names); intros; simpl
  end.
Hint Extern 1 (_ :> trm_Lam _; _) => (typing_apply_TLam).

Ltac typing_apply_Lam :=
  match goal with
    | [|- _ :> trm_lam _ _; _] =>
      let names := roundup_names in
        apply T_Lam with (L:=names); intros; simpl
  end.
Hint Extern 1 (_ :> trm_lam _; _) => (typing_apply_Lam).

Fixpoint ctx_lookup_type (n:nat) (G:context) : option typ :=
  match G with
    | nil => None
    | ((x,T)::G') =>
      match (nat_compare x n) with
        | Eq => Some T
        | _ => ctx_lookup_type n G'
      end
  end.
Fixpoint construct_type (G:context) (t:trm) (t':trm) {struct t} : option typ :=
  match t with
    | trm_bvar _ =>
      match t' with
        | trm_fvar n => (* Lookup the type of n in G. *)
          let T := ctx_lookup_type n G in T
        | _ => None
      end
    | trm_fvar n => (* Lookup the type of n in G. *)
      let T := ctx_lookup_type n G in T
    | trm_lam A b =>
      match t' with
        | trm_lam A' b' =>
          let y := pick_fresh (dom_t G) in
            let a := open_t 0 (trm_fvar y) b' in
              let T' := construct_type ((y,A)::G) b a in
                match T' with
                  | Some B => Some (typ_arrow A B)
                  | _ => None
                end
        | _ => None
      end
    | _ => None
  end.

Hint Extern 1 (((_,_) :: _) :> _ ; _) =>
  match goal with
    | [|- ((?x,?A) :: ?G) :> ?t ; ?T] =>
      match goal with
        |  [H : G :> t ; T |- _] =>
          apply weakening_typing with (G2:=((x,A)::nil)) (G1:=G) (G3:=nil)
      end
  end; simpl; auto.

Ltac typing_apply_app :=
  match goal with
    | [ |- _ :> trm_app _ (trm_fvar ?x) ; _ ] =>
      match goal with
        | [ |- (_ :: (x,?T) :: _ :: nil) :> _ ; _] =>
          apply T_App with (T1:=T)
        | [ |- (_ :: _ :: (x,?T) :: nil) :> _ ; _] =>
          apply T_App with (T1:=T)
      end
    | [ |- ?G :> trm_app _ ?a ; _] =>
      match goal with
        | [H : _ :> a ; ?A |- _] =>
          apply T_App with (T1:=A)
        | _ =>
          let T := eval simpl in (construct_type G a a) in
            match T with
              | None => fail 2 "Failed to Construct Type of:" a
              | Some ?T' => apply T_App with (T1:=T')
            end
      end
    | [|- _ :> trm_app ?t _; _] =>
       match goal with
         | [H : _ :> t ; typ_arrow ?A _ |- _] =>
           apply T_App with (T1:=A)
       end
  end.
Hint Extern 1 (_ :> trm_app _ _; _) => (typing_apply_app).

Fixpoint type_eq (A:typ) (B:typ) : comparison :=
  match A with
    | typ_arrow A1 A2 =>
      match B with
        | typ_arrow B1 B2 =>
          match (type_eq A1 B1) with
            | Eq =>
              match (type_eq A2 B2) with
                | Eq => Eq
                | _ => Lt
              end
            | _ => Lt
          end
        | _ => Lt
      end
    | typ_forall A1 =>
      match B with
        | typ_forall B1 =>
          match (type_eq A1 B1) with
            | Eq => Eq
            | _ => Lt
          end
        | _ => Lt
      end
    | typ_base =>
      match B with
        | typ_base => Eq
        | _ => Lt
      end
    | typ_fvar m =>
      match B with
        | typ_fvar m' =>
          match (nat_compare m m') with
            | Eq => Eq
            | _ => Lt
          end
        | _ => Lt
      end
    | typ_bvar m =>
      match B with
        | typ_bvar m' =>
          match (nat_compare m m') with
            | Eq => Eq
            | _ => Lt
          end
        | _ => Lt
      end
  end.

Fixpoint close_type (A:typ) (n:nat) (B:typ) : typ :=
  match B with
    | typ_arrow B1 B2 =>
      typ_arrow
      (match (type_eq B1 A) with
         | Eq => (typ_bvar n)
         | _ => (close_type A n B1)
       end)
      (match (type_eq B2 A) with
         | Eq => (typ_bvar n)
         | _ => (close_type A n B2)
       end)
    | typ_forall B1 =>
      typ_forall
      (match (type_eq B1 A) with
         | Eq => (typ_bvar (S n))
         | _ => close_type A (S n) B1
       end)
    | typ_base => typ_base
    | typ_bvar m =>
      match (type_eq B A) with
        | Eq => typ_bvar n
        | _ => typ_bvar m
      end
    | typ_fvar m =>
      match (type_eq B A) with
        | Eq => typ_fvar n
        | _ => typ_fvar m
      end
  end.
Ltac typing_apply_tapp :=
  match goal with
    | [ |- _ :> trm_tapp _ ?A; ?B] =>
      let T := (constr:(close_type A 0 B)) in
        let a := T in
          idtac a
  end.

Ltac type_check :=
  repeat match goal with
    | [|- _ :> trm_fvar _ ; _] =>
      try typing_apply_var
    | [|- _ :> trm_Lam _ ; _] =>
      try typing_apply_TLam
    | [|- _ :> trm_lam _ _ ; _] =>
      try typing_apply_Lam
    | [|- _ :> trm_app _ _ ; _] =>
      try typing_apply_app
  end; try destruct_nin; auto.
(* end hide *)

Lemma pair_cons_typing : nil :> pair_cons ; pair_cons_type.
Proof.
  unfold pair_cons; unfold pair_cons_type; type_check.
Qed.

Lemma pair_typing : forall A B a b,
  lc_T A ->
  lc_T B ->
  nil :> a ; A ->
  nil :> b ; B ->
  nil :> pair A B a b ; pair_type A B.
Proof.
  intros; unfold pair; unfold pair_type; try type_check.

  apply T_AppT with (T:=typ_arrow A
     (typ_arrow (typ_bvar 0)
        (typ_forall
          (typ_arrow (typ_arrow A (typ_arrow (typ_bvar 1) (typ_bvar 0))) (typ_bvar 0))))); simpl;   auto.
  apply T_AppT with (T:=typ_forall
     (typ_arrow (typ_bvar 1)
        (typ_arrow (typ_bvar 0)
           (typ_forall
              (typ_arrow (typ_arrow (typ_bvar 2) (typ_arrow (typ_bvar 1) (typ_bvar 0)))
                 (typ_bvar 0)))))); simpl; auto.
  apply pair_cons_typing.

  repeat (rewrite -> open_T_id; auto).
Qed.
(* begin hide *)
Hint Resolve pair_typing.
(* end hide *)

(** Using our [pair] definition we can construct pairs, but we still need ways of getting
    the data back out of the pairs.  Next we define the first and second projections of
    our pairs. First, we need two very simple functions.  They are used for deciding which
    projection we want. The first function, [arg_one], is used to get the first projection,
    while the second, [arg_two] is used to get the second. *)

Definition arg_one A B := trm_lam A (trm_lam B (trm_bvar 1)).
Definition arg_two A B := trm_lam A (trm_lam B (trm_bvar 0)).

(** Now using [arg_one] and [arg_two] we can define the first and second projections
    as follows: *)

Definition fst (A:typ) (B:typ) (p:trm) := trm_app (trm_tapp p A) (arg_one A B).
Definition snd (A:typ) (B:typ) (p:trm) := trm_app (trm_tapp p B) (arg_two A B).

(** Again we must be sure these are the first definitions.  We first show that
    [fst] and [snd] have the expect type. *)

Lemma fst_typing : forall A B p,
  lc_T A ->
  lc_T B ->
  nil :> p ; pair_type A B ->
  nil :> fst A B p ; A.
Proof.
  intros; unfold fst; unfold arg_one; try type_check.
  apply T_AppT with (T:=typ_arrow (typ_arrow A (typ_arrow B (typ_bvar 0))) (typ_bvar 0));
    simpl; auto.
  repeat rewrite -> open_T_id; auto.
Qed.

Lemma snd_typing : forall A B p,
  lc_T A ->
  lc_T B ->
  nil :> p ; pair_type A B ->
  nil :> snd A B p ; B.
Proof.
  intros; unfold snd; unfold arg_two; try type_check.
  apply T_AppT with (T:=typ_arrow (typ_arrow A (typ_arrow B (typ_bvar 0))) (typ_bvar 0));
    simpl; auto.
  repeat rewrite -> open_T_id; auto.
Qed.

(* begin hide *)
Lemma Eq_refl : forall a A G, G :> a <~> a ; A.
Proof.
  admit.
Qed.
Hint Extern 1 (_ :> _ <~> _ ; _) => (apply Eq_refl).

Hint Extern 1 =>
  (match goal with
     [|- context[open_T _ _ ?A] ] =>
     match goal with
       | [ _ : lc_T A |- _] =>
         repeat rewrite -> open_T_id; auto
     end
   end).

Ltac eq_apply_app :=
  match goal with
    [ |- ?G :> trm_app _ ?t <~> trm_app _ _ ; _] =>
    match goal with
      | [ H : _ :> t ; ?T |- _] =>
        apply Eq_app with (A:=T)
      | _ =>
        let T := eval simpl in (construct_type G t t) in
          match T with
            | None => fail 1 "eq_apply_app: Failed to construct the type of" t
            | Some ?T' => apply Eq_app with (A:=T')
          end
    end
  end; auto.

Ltac eq_apply_beta :=
  match goal with
    | [ |- ?G :> trm_app (trm_lam _ ?b) ?a <~> _; _] =>
      apply Eq_beta with (L:=nil) (a':=a) (b':=b)
  end; simpl; auto.
(* end hide *)

(** Recall that we defined \(\beta\eta\)-equality.  All equational
    reasoning we will do will be using \(\beta\eta\)-equality. Using this
    we show that applying [fst] to a [pair] is equivalent to the first project
    of the pair. *)

Lemma fst_eq : forall A B a b,
  nil :> a ; A ->
  nil :> b ; B ->
  nil :> (pair A B a b) ; pair_type A B ->
  nil :> fst A B (pair A B a b) <~> a ; A.
Proof.
  intros A B a b H1 H2; intros; unfold fst; unfold arg_one; unfold pair; unfold pair_cons.
  copy_hyp H1 H1a.
  copy_hyp H2 H2a.
  apply typing_lc in H1; destruct H1.
  apply typing_lc in H2; destruct H2.

  apply Eq_trans with (t3:=
    trm_app
    (trm_tapp
      (trm_app
        (trm_app
          (trm_tapp
            (open_tT 0 A
              (trm_Lam
                  (trm_lam (typ_bvar 1)
                    (trm_lam (typ_bvar 0)
                      (trm_Lam
                        (trm_lam
                          (typ_arrow
                            (typ_bvar 2)
                            (typ_arrow
                              (typ_bvar 1)
                              (typ_bvar 0)))
                          (trm_app
                            (trm_app
                              (trm_bvar 0)
                              (trm_bvar 2))
                            (trm_bvar 1)))))))) B) a) b) A) (trm_lam A (trm_lam B (trm_bvar 1)))); simpl; auto; try eq_apply_app.

  apply Eq_tapp with (A:=typ_arrow (typ_arrow A (typ_arrow B (typ_bvar 0))) (typ_bvar 0)); simpl; auto; try eq_apply_app.
  eq_apply_app.

  apply Eq_tapp with (A:=typ_arrow A
     (typ_arrow (typ_bvar 0)
        (typ_forall
           (typ_arrow (typ_arrow A (typ_arrow (typ_bvar 1) (typ_bvar 0))) (typ_bvar 0))))); simpl; auto.

  apply Eq_tbeta with (L:=FV_T A++FV_T B)
    (b:=trm_Lam
     (trm_lam (typ_bvar 1)
        (trm_lam (typ_bvar 0)
           (trm_Lam
              (trm_lam (typ_arrow (typ_bvar 2) (typ_arrow (typ_bvar 1) (typ_bvar 0)))
                 (trm_app (trm_app (trm_bvar 0) (trm_bvar 2)) (trm_bvar 1)))))))
    (A:=typ_forall
      (typ_arrow (typ_bvar 1)
        (typ_arrow (typ_bvar 0)
          (typ_forall
            (typ_arrow (typ_arrow (typ_bvar 2) (typ_arrow (typ_bvar 1) (typ_bvar 0)))
              (typ_bvar 0)))))); simpl; auto.

  apply Eq_trans with (t3:=trm_app
        (trm_tapp
           (trm_app
              (trm_app
                 (open_tT 0 B
                       (trm_lam A
                          (trm_lam (typ_bvar 0)
                             (trm_Lam
                                (trm_lam
                                   (typ_arrow A
                                      (typ_arrow (typ_bvar 1) (typ_bvar 0)))
                                   (trm_app
                                      (trm_app (trm_bvar 0) (trm_bvar 2))
                                      (trm_bvar 1))))))) a) b) A)
        (trm_lam A (trm_lam B (trm_bvar 1)))); simpl; auto.
  eq_apply_app.
  apply Eq_tapp with (A:=typ_arrow (typ_arrow A (typ_arrow B (typ_bvar 0))) (typ_bvar 0)); simpl; auto.
  eq_apply_app.
  eq_apply_app.
  apply Eq_tbeta with (L:=nil)
    (b:=(trm_lam A
              (trm_lam (typ_bvar 0)
                 (trm_Lam
                    (trm_lam
                       (typ_arrow A (typ_arrow (typ_bvar 1) (typ_bvar 0)))
                       (trm_app (trm_app (trm_bvar 0) (trm_bvar 2))
                          (trm_bvar 1)))))))
    (A:=typ_arrow A
     (typ_arrow (typ_bvar 0)
        (typ_forall
           (typ_arrow (typ_arrow A (typ_arrow (typ_bvar 1) (typ_bvar 0))) (typ_bvar 0))))); simpl; auto.

  apply Eq_trans with (t3:=trm_app
        (trm_tapp
           (trm_app
              (open_t 0 a
                    (trm_lam B
                       (trm_Lam
                          (trm_lam
                             (typ_arrow (open_T 1 B A)
                                (typ_arrow B (typ_bvar 0)))
                             (trm_app (trm_app (trm_bvar 0) (trm_bvar 2))
                                (trm_bvar 1)))))) b) A)
        (trm_lam A (trm_lam B (trm_bvar 1)))); simpl; auto.
   eq_apply_app.
   apply Eq_tapp with (A:=typ_arrow (typ_arrow A (typ_arrow B (typ_bvar 0))) (typ_bvar 0)); simpl; auto.
   eq_apply_app.

  apply Eq_beta with (L:=nil)
    (a':=a)
    (b':=trm_lam B
              (trm_Lam
                 (trm_lam
                    (typ_arrow (open_T 1 B A) (typ_arrow B (typ_bvar 0)))
                    (trm_app (trm_app (trm_bvar 0) (trm_bvar 2)) (trm_bvar 1))))); simpl; auto.

  apply Eq_trans with (t3:=trm_app
        (trm_tapp
           (open_t 0 b
                 (trm_Lam
                    (trm_lam
                       (typ_arrow (open_T 1 B A) (typ_arrow B (typ_bvar 0)))
                       (trm_app (trm_app (trm_bvar 0) a) (trm_bvar 1)))))
           A) (trm_lam A (trm_lam B (trm_bvar 1)))); simpl; auto.
  eq_apply_app.
  apply Eq_tapp with (A:=typ_arrow (typ_arrow A (typ_arrow B (typ_bvar 0))) (typ_bvar 0)); simpl; auto.
  eq_apply_beta.

  apply Eq_trans with (t3:=trm_app
        (open_tT 0 A
              (trm_lam (typ_arrow (open_T 1 B A) (typ_arrow B (typ_bvar 0)))
                 (trm_app (trm_app (trm_bvar 0) (open_t 1 b a)) b)))
        (trm_lam A (trm_lam B (trm_bvar 1)))); simpl; auto.

  eq_apply_app.
  apply Eq_tbeta with (L:=nil)
    (b:=trm_lam (typ_arrow A (typ_arrow B (typ_bvar 0)))
              (trm_app (trm_app (trm_bvar 0) (open_t 1 b a)) b))
    (A:=typ_arrow (typ_arrow A (typ_arrow B (typ_bvar 0))) (typ_bvar 0)); simpl; auto.

  apply Eq_trans with (t3:=
          open_t 0 (trm_lam A (trm_lam B (trm_bvar 1)))
           (trm_app (trm_app (trm_bvar 0) (open_tT 0 A (open_t 1 b a)))
              (open_tT 0 A b))); simpl; auto.

  eq_apply_beta; autorewrite with open_rw_db; auto.

  repeat autorewrite with open_rw_db; auto.

  apply Eq_trans with
    (t3:=trm_app (open_t 0 a (trm_lam B (trm_bvar 1))) b); simpl.
  apply Eq_app with (A:=B); simpl; auto; eq_apply_beta.

  eq_apply_beta; autorewrite with open_rw_db; auto.
Qed.

(* Finally, we do the same for [snd]. *)
Lemma snd_eq : forall A B a b,
  nil :> a ; A ->
  nil :> b ; B ->
  nil :> (pair A B a b) ; pair_type A B ->
  nil :> snd A B (pair A B a b) <~> b ; B.
Proof.
  intros A B a b H1 H2; intros; unfold snd; unfold arg_two; unfold pair; unfold pair_cons.
  copy_hyp H1 H1a.
  copy_hyp H2 H2a.
  apply typing_lc in H1; destruct H1.
  apply typing_lc in H2; destruct H2.

  apply Eq_trans with (t3:=
    trm_app
    (trm_tapp
      (trm_app
        (trm_app
          (trm_tapp
            (open_tT 0 A
              (trm_Lam
                  (trm_lam (typ_bvar 1)
                    (trm_lam (typ_bvar 0)
                      (trm_Lam
                        (trm_lam
                          (typ_arrow
                            (typ_bvar 2)
                            (typ_arrow
                              (typ_bvar 1)
                              (typ_bvar 0)))
                          (trm_app
                            (trm_app
                              (trm_bvar 0)
                              (trm_bvar 2))
                            (trm_bvar 1)))))))) B) a) b) B) (trm_lam A (trm_lam B (trm_bvar 0)))); simpl; auto; try eq_apply_app.

  apply Eq_tapp with (A:=typ_arrow (typ_arrow A (typ_arrow B (typ_bvar 0))) (typ_bvar 0)); simpl; auto; try eq_apply_app.
  eq_apply_app.

  apply Eq_tapp with (A:=typ_arrow A
     (typ_arrow (typ_bvar 0)
        (typ_forall
           (typ_arrow (typ_arrow A (typ_arrow (typ_bvar 1) (typ_bvar 0))) (typ_bvar 0))))); simpl; auto.

  apply Eq_tbeta with (L:=FV_T A++FV_T B)
    (b:=trm_Lam
     (trm_lam (typ_bvar 1)
        (trm_lam (typ_bvar 0)
           (trm_Lam
              (trm_lam (typ_arrow (typ_bvar 2) (typ_arrow (typ_bvar 1) (typ_bvar 0)))
                 (trm_app (trm_app (trm_bvar 0) (trm_bvar 2)) (trm_bvar 1)))))))
    (A:=typ_forall
      (typ_arrow (typ_bvar 1)
        (typ_arrow (typ_bvar 0)
          (typ_forall
            (typ_arrow (typ_arrow (typ_bvar 2) (typ_arrow (typ_bvar 1) (typ_bvar 0)))
              (typ_bvar 0)))))); simpl; auto.

  apply Eq_trans with (t3:=trm_app
        (trm_tapp
           (trm_app
              (trm_app
                 (open_tT 0 B
                       (trm_lam A
                          (trm_lam (typ_bvar 0)
                             (trm_Lam
                                (trm_lam
                                   (typ_arrow A
                                      (typ_arrow (typ_bvar 1) (typ_bvar 0)))
                                   (trm_app
                                      (trm_app (trm_bvar 0) (trm_bvar 2))
                                      (trm_bvar 1))))))) a) b) B)
        (trm_lam A (trm_lam B (trm_bvar 0)))); simpl; auto.
  eq_apply_app.
  apply Eq_tapp with (A:=typ_arrow (typ_arrow A (typ_arrow B (typ_bvar 0))) (typ_bvar 0)); simpl; auto.
  eq_apply_app.
  eq_apply_app.
  apply Eq_tbeta with (L:=nil)
    (b:=(trm_lam A
              (trm_lam (typ_bvar 0)
                 (trm_Lam
                    (trm_lam
                       (typ_arrow A (typ_arrow (typ_bvar 1) (typ_bvar 0)))
                       (trm_app (trm_app (trm_bvar 0) (trm_bvar 2))
                          (trm_bvar 1)))))))
    (A:=typ_arrow A
     (typ_arrow (typ_bvar 0)
        (typ_forall
           (typ_arrow (typ_arrow A (typ_arrow (typ_bvar 1) (typ_bvar 0))) (typ_bvar 0))))); simpl; auto.

  apply Eq_trans with (t3:=trm_app
        (trm_tapp
           (trm_app
              (open_t 0 a
                    (trm_lam B
                       (trm_Lam
                          (trm_lam
                             (typ_arrow (open_T 1 B A)
                                (typ_arrow B (typ_bvar 0)))
                             (trm_app (trm_app (trm_bvar 0) (trm_bvar 2))
                                (trm_bvar 1)))))) b) B)
        (trm_lam A (trm_lam B (trm_bvar 0)))); simpl; auto.
   eq_apply_app.
   apply Eq_tapp with (A:=typ_arrow (typ_arrow A (typ_arrow B (typ_bvar 0))) (typ_bvar 0)); simpl; auto.
   eq_apply_app.
   eq_apply_beta.

  apply Eq_trans with (t3:=trm_app
        (trm_tapp
           (open_t 0 b
                 (trm_Lam
                    (trm_lam
                       (typ_arrow (open_T 1 B A) (typ_arrow B (typ_bvar 0)))
                       (trm_app (trm_app (trm_bvar 0) a) (trm_bvar 1)))))
           B) (trm_lam A (trm_lam B (trm_bvar 0)))); simpl; auto.
  eq_apply_app.
  apply Eq_tapp with (A:=typ_arrow (typ_arrow A (typ_arrow B (typ_bvar 0))) (typ_bvar 0)); simpl; auto.
  eq_apply_beta.

  apply Eq_trans with (t3:=trm_app
        (open_tT 0 B
              (trm_lam (typ_arrow (open_T 1 B A) (typ_arrow B (typ_bvar 0)))
                 (trm_app (trm_app (trm_bvar 0) (open_t 1 b a)) b)))
        (trm_lam A (trm_lam B (trm_bvar 0)))); simpl; auto.

  eq_apply_app.
  autorewrite with open_rw_db; auto.
  apply Eq_tbeta with (L:=nil)
    (b:=trm_lam (typ_arrow A (typ_arrow B (typ_bvar 0)))
              (trm_app (trm_app (trm_bvar 0) a) b))
    (A:=typ_arrow (typ_arrow A (typ_arrow B (typ_bvar 0))) (typ_bvar 0)); simpl;
      autorewrite with open_rw_db; auto.

  apply Eq_trans with (t3:=
          open_t 0 (trm_lam A (trm_lam B (trm_bvar 0)))
           (trm_app (trm_app (trm_bvar 0) (open_tT 0 A (open_t 1 b a)))
              (open_tT 0 B b))); simpl; auto.

  eq_apply_beta; autorewrite with open_rw_db; auto.

  autorewrite with open_rw_db; auto.

  apply Eq_trans with
    (t3:=trm_app (open_t 0 a (trm_lam B (trm_bvar 0))) b); simpl.
  repeat autorewrite with open_rw_db; auto.
  apply Eq_app with (A:=A); simpl; auto; eq_apply_beta.

  eq_apply_beta; autorewrite with open_rw_db; auto.
Qed.

(** We have set out on a journey to better understand the relationship between
    church-encoded pairs in system F and categorical products.  So far we have defined
    system F with \(\beta\eta\)-equality and defined church-encoded pairs in system F.
    In the next post we will layout all the necessary category theory we will need for the
    main result. Stay tuned. *)

(* begin hide *)
Definition mp_prod_def A B C f g u :=
  (nil :> u ; typ_arrow C (pair_type A B)) /\
  (nil :> f <~> (trm_lam C (fst A B (trm_app u (trm_bvar 0)))) ; typ_arrow C A) /\
  (nil :> g <~> (trm_lam C (snd A B (trm_app u (trm_bvar 0)))) ; typ_arrow C B).

Definition couple C A B f g := trm_lam C (pair A B (trm_app f (trm_bvar 0)) (trm_app g (trm_bvar 0))).

(* Shows the UMP diagram commutes. *)
Theorem mp_prod : forall f g A B C,
  nil :> f ; typ_arrow C A ->
  nil :> g ; typ_arrow C B ->
  exists u, mp_prod_def A B C f g u.
Proof.
  intros.
  exists (couple C A B f g).
  unfold mp_prod_def.

  copy_hyp H H'; apply typing_lc in H'; destruct H'.
  copy_hyp H0 H0'; apply typing_lc in H0'; destruct H0'.
  invert_typing H2.
  invert_typing H4.

  split.
  apply T_Lam with (L:=nil); intros.
  unfold pair. unfold pair_cons. simpl. autorewrite with open_rw_db; auto.
  admit.

  split.
  admit.
  admit.
Qed.

(* This is where we run into trouble. Beta-eta equality
 * cannot prove that the universal map is unique. *)
Lemma a : forall c A B,
  nil :> c ; pair_type A B ->
  nil :> (pair A B (fst A B c) (snd A B c)) <~> c ; pair_type A B.
Proof.
  intros c A B H1.

  Print pair.
  Print pair_cons.

  Lemma c : forall A B a b,
    nil :> pair A B a b <~> (trm_Lam (trm_lam (A --> (B --> (typ_bvar 0))) (trm_app (trm_app (trm_bvar 0) a) b))) ; pair_type A B.
  Proof.
    admit.
  Qed.

  Lemma b : forall c A B,
    nil :> c ; pair_type A B ->
    exists a, exists b,
      nil :> c <~> pair A B a b ; pair_type A B.
  Proof.
    intros c A B H1.

    inversion H1; subst.

    inversion H0.

    simpl in *. unfold pair; unfold pair_type in *.
  Qed.
Qed.

Theorem ump_counter : forall A B C f g,
  nil :> f ; C --> A ->
  nil :> g ; C --> B ->
  exists u',
    mp_prod_def A B C f g u' ->
    ~ (nil :> couple C A B f g <~> u' ; typ_arrow C (pair_type A B)).
Proof.
  intros A B C f g H1 H2.

  unfold pair.
Qed.
(* end hide *)