Require Export pcf_rep initial_terminal.

Require Export Coq.Program.Equality. (* for dependent induction *)

Set Implicit Arguments.
Unset Strict Implicit.

Unset Automatic Introduction.

Section initial_rep.

Notation "'TY'" := PCF.TY.
(*Notation "'IP'" := (IPO TY).*)
Notation "'IT'" := (ITYPE TY).
Notation "a '~>' b" := (PCF.arrow a b) (at level 69, right associativity).
(* Notation "a ~> b" := (Module_Hom a b) (at level 50).*)
(*Notation "a 'x' b" := (Prod_Mod _ a b) (at level 30).*)

(*Notation "a 'x' b" := (product (*C:= MOD _ _*) a b) (at level 30).*)

(* Notation "P ^ z" := (FIB_MOD _ z P). *)
Notation "P [ z ]" := (ITFIB_MOD _ z P) (at level 35).

(*Notation "P ''' s" := (DER_MOD _ _ s P ) (at level 25).*)
Notation "'d' P // s" := (ITDER_MOD _ _ s P) (at level 25).
(*Notation " '*' " := (Term (*C:=MOD _ _*)).*)
Notation "'*'" := (Term (C:=MOD _ TYPE)).
Notation "'Bool'" := PCF.Bool.
Notation "'Nat'" := PCF.Nat.

Notation "f 'X' g" := (product_mor (*C:= MOD _ _ *) _ f g)(at level 30).

Notation "'FM'" := (#(ITFIB_MOD _ _ )).
Notation "'FPB'":= (ITFIB_PB _ _ _ ).
Notation "'PRPB'":= (PROD_PB _ _ _ _ ).
Notation "'PBF'":= (ITPB_FIB _ _ _ ).
Notation "'PBM'":= (#(PB_MOD _ _ )).
Notation "'DM'":= (#(ITDER_MOD _ _ _ )).
Notation "'DPB'":= (ITDER_PB _ _ _ ).
Notation "y [* := z ]":= (ITsubstar z y)(at level 55).

Definition PCFinit : Monad IT := PCF_monad.

(** a very boring part : definition of all the module morphisms we need *)

Program Instance PCFApp_struct (r s : TY) :
Module_Hom_struct
  (S:=Prod_Mod (P:=PCFinit) TYPE_prod
     (ITFibre_Mod (P:=PCFinit) PCFinit (r ~> s))
     (ITFibre_Mod (P:=PCFinit) PCFinit r))
  (T:=ITFibre_Mod (P:=PCFinit) PCFinit s)
  (fun v z => PCF.App (fst z) (snd z)).

Definition PCFApp (r s: TY) := Build_Module_Hom (PCFApp_struct r s).

Program Instance PCFLam_struct (r s: TY): Module_Hom_struct
  (S:=ITFibre_Mod (P:=PCFinit)
     (IT_Der_Mod (P:=PCFinit) (D:=ITYPE_struct TY) PCFinit r) s)
  (T:=ITFibre_Mod (P:=PCFinit) PCFinit (r ~> s))
   (fun v z => PCF.Lam z).
Next Obligation.
Proof.
  apply f_equal.
  apply PCF.subst_eq.
  simpl.
  intros u y.
  destruct y; simpl; auto.
  unfold PCF.inj_. simpl.
  set (H:= PCF.subst_eq_rename).
  apply eq_sym.
  apply H.
Qed.

Definition PCFLam (r s: TY) := Build_Module_Hom (PCFLam_struct r s).

Program Instance PCFRec_struct (t: TY) : Module_Hom_struct
  (S:= ITFibre_Mod (P:=PCFinit) PCFinit (t ~> t))
  (T:= ITFibre_Mod (P:=PCFinit) PCFinit t)
   (fun V z => PCF.Rec z).

Definition PCFRec (t: TY) := Build_Module_Hom (PCFRec_struct t).

Program Instance PCFttt_struct : Module_Hom_struct
  (S:= MOD_Term PCFinit TYPE_term)
  (T:=ITFibre_Mod (P:=PCFinit) PCFinit Bool)
   (fun v _ => PCF.Const v PCF.ttt).

Definition PCFttt := Build_Module_Hom PCFttt_struct.

Program Instance PCFfff_struct : Module_Hom_struct
  (S:= MOD_Term PCFinit TYPE_term)
  (T:=ITFibre_Mod (P:=PCFinit) PCFinit Bool)
   (fun v _ => PCF.Const v PCF.fff).

Definition PCFfff := Build_Module_Hom PCFfff_struct.

Program Instance PCFsucc_struct : Module_Hom_struct
  (S:= MOD_Term PCFinit TYPE_term)
  (T:=ITFibre_Mod (P:=PCFinit) PCFinit _ )
   (fun v _ => PCF.Const v PCF.succ).

Definition PCFsucc := Build_Module_Hom PCFsucc_struct.

Program Instance PCFnats_struct (m: nat) : Module_Hom_struct
   (S:= MOD_Term PCFinit TYPE_term)
  (T:=ITFibre_Mod (P:=PCFinit) PCFinit _)
   (fun v _ => PCF.Const v (PCF.Nats m)).

Definition PCFnats (m:nat) := Build_Module_Hom (PCFnats_struct m).

Program Instance PCFzero_struct : Module_Hom_struct
  (S:= MOD_Term PCFinit TYPE_term)
  (T:=ITFibre_Mod (P:=PCFinit) PCFinit _ )
   (fun v _ => PCF.Const v PCF.zero).

Definition PCFzero := Build_Module_Hom PCFzero_struct.

Program Instance PCFcondN_struct : Module_Hom_struct
  (S:=MOD_Term PCFinit TYPE_term)
  (T:=ITFibre_Mod (P:=PCFinit) PCFinit (Bool ~> Nat ~> Nat ~> Nat))
    (fun V _ => PCF.Const V PCF.condN).

Definition PCFcondN := Build_Module_Hom PCFcondN_struct.

Program Instance PCFcondB_struct : Module_Hom_struct
  (S:=MOD_Term PCFinit _ )
  (T:=ITFibre_Mod (P:=PCFinit) PCFinit (Bool ~> Bool ~> Bool ~> Bool))
    (fun V _ => PCF.Const V PCF.condB).

Definition PCFcondB := Build_Module_Hom PCFcondB_struct.

Program Instance PCFBottom_struct (t: TY) : Module_Hom_struct
  (S:=MOD_Term PCFinit _ )
  (T:=ITFibre_Mod (P:=PCFinit) PCFinit t)
    (fun V _ => PCF.Bottom V t).

Definition PCFBottom t:= Build_Module_Hom (PCFBottom_struct t).

Program Instance PCF_rep_struct : PCF_rep_struct PCFinit:= {
  App := PCFApp;
  Abs := PCFLam;
  Rec := PCFRec;
  ttt := PCFttt;
  fff := PCFfff;
  succ := PCFsucc;
  nats := PCFnats;
  zero := PCFzero;
  condN := PCFcondN;
  condB := PCFcondB;
  Bottom := PCFBottom
}.

(** PCF is a representation of PCFPO *)

Definition PCF_PCF_rep := Build_PCF_rep PCF_rep_struct.

Section monad_hom.

Variable R: PCF_rep.

(**   the function [(PCF V t) -> (R V t)] *)

Definition init_d (V:IT) (t:TY):
 (PCF.PCF V t) -> (R V t).
intros V t v.

induction v; simpl.

apply (Bottom t V tt).
destruct c.
apply (nats n V tt).
apply (ttt V tt).
apply (fff V tt).
apply (succ V tt).
apply (zero V tt).
apply (condN V tt).
apply (condB V tt).
(*apply (weta (Monad_struct := R)).*)
apply (weta (Monad_struct := R) V t v).
apply (App s t  V (IHv1, IHv2)).
apply (Abs _ _ V IHv).
apply (Rec _ V IHv).
Defined.

(** some lemmata about how compilation commutes with
    - rename (lift)
    - substitution (kleisli) (hidden in the instance declaration)
*)

Lemma init_d_rename (V : IT) t (v : PCF.PCF V t) W (f : V ---> W) :
      init_d (PCF.rename_ f v) =
        lift f _ (init_d v).
Proof.
  intros V t v.
  induction v; unfold lift;
  simpl; intros.

  set (H:= @mod_hom_mkl _ _ _ R _ _ _ _ _ _  (Bottom t)).
  simpl in H.
  apply H.

  destruct c; intros; simpl.
    set (H:= @mod_hom_mkl _ _ _ R _ _ _ _ _ _  (nats n)).
    simpl in H.
    apply H.
    set (H:= @mod_hom_mkl _ _ _ R _ _ _ _ _ _  (ttt)).
    simpl in H.
    apply H.
    set (H:= @mod_hom_mkl _ _ _ R _ _ _ _ _ _  (fff)).
    simpl in H.
    apply H.
    set (H:= @mod_hom_mkl _ _ _ R _ _ _ _ _ _  (succ)).
    simpl in H.
    apply H.
    set (H:= @mod_hom_mkl _ _ _ R _ _ _ _ _ _  (zero)).
    simpl in H.
    apply H.
    set (H:= @mod_hom_mkl _ _ _ R _ _ _ _ _ _  (condN)).
    simpl in H.
    apply H.
    set (H:= @mod_hom_mkl _ _ _ R _ _ _ _ _ _  (condB)).
    simpl in H.
    apply H.
    set (H:= eta_kl (Monad_struct := R) ).
    simpl in H.
    rewrite H; auto.
    rewrite  IHv1.
    rewrite IHv2.
        set (H:= @mod_hom_mkl _ _ _ R _ _ _ _ _ _  (App s t)).
        simpl in *.
        rewrite <- H.
        simpl. apply f_equal.
        unfold lift in *. simpl. auto.
     simpl.
    unfold lift in IHv.
    rewrite IHv.
    set (H:= @mod_hom_mkl _ _ _ R _ _ _ _ _ _  (Abs t s)).
        simpl in *.
        rewrite <- H.
        apply f_equal.
        assert (H':= kleisli_oid (Monad_struct := R)).
        unfold Proper in H'.  red in H'.
        simpl in H'.
        unfold shift.
        simpl.
        apply H'.
        intros t0 x0; simpl.
        destruct x0; simpl; intros; auto.
        unfold lift.
        assert (H2:= eta_kl (Monad_struct:= R)).
        simpl in H2.
        rewrite H2. simpl. auto.

   rewrite IHv.
   set (H:= @mod_hom_mkl _ _ _ R _ _ _ _ _ _  (Rec t)).
   simpl in H.
   rewrite <- H.
   simpl; auto.
Qed.

Lemma init_d_inj (Y : IT) t t0 (v : PCF.PCF Y t0) : init_d (PCF.inj_ t v) =
kleisli (Monad_struct := R)
  (some t (A:=Y);; weta (opt t Y)) t0 (init_d v).
Proof.
  intros; simpl.
  unfold PCF.inj_.
  apply init_d_rename.
Qed.

(**  init_d is a monad morphism *)

Program Instance Init_Rep_mor : Monad_Hom_struct (P:=PCF_monad)
                                                 (Q:= R)
      (fun V t z => init_d  z).
Next Obligation.
Proof.
  generalize dependent Y.
  induction x; simpl;
  intros.
    set (H:= @mod_hom_mkl _ _ _ R _ _ _ _ _ _  (Bottom t)).
    simpl in H.
    apply H.

  destruct c; intros; simpl.
    set (H:= @mod_hom_mkl _ _ _ R _ _ _ _ _ _  (nats n)).
    simpl in H.
    apply H.
    set (H:= @mod_hom_mkl _ _ _ R _ _ _ _ _ _  (ttt)).
    simpl in H.
    apply H.
    set (H:= @mod_hom_mkl _ _ _ R _ _ _ _ _ _  (fff)).
    simpl in H.
    apply H.
    set (H:= @mod_hom_mkl _ _ _ R _ _ _ _ _ _  (succ)).
    simpl in H.
    apply H.
    set (H:= @mod_hom_mkl _ _ _ R _ _ _ _ _ _  (zero)).
    simpl in H.
    apply H.
    set (H:= @mod_hom_mkl _ _ _ R _ _ _ _ _ _  (condN)).
    simpl in H.
    apply H.
    set (H:= @mod_hom_mkl _ _ _ R _ _ _ _ _ _  (condB)).
    simpl in H.
    apply H.
    set (H:= eta_kl (Monad_struct := R) ).
    simpl in H.
    rewrite H; auto.
    rewrite IHx1.
    rewrite IHx2.
        set (H:= @mod_hom_mkl _ _ _ R _ _ _ _ _ _  (App s t)).
        simpl in H.
        rewrite <- H.
        apply f_equal. simpl. auto.
    rewrite IHx.
        set (H:= @mod_hom_mkl _ _ _ R _ _ _ _ _ _  (Abs t s)).
        simpl in H.
        rewrite <- H.
        apply f_equal.
        assert (H':= kleisli_oid (Monad_struct := R)).
        unfold Proper in H'.  red in H'.
        simpl in H'.
        unfold shift.
        simpl.
        apply H'.
        intros; simpl.
        destruct x0; simpl; intros; auto.
        unfold lift.
        rewrite init_d_inj. auto.
     rewrite IHx.
     set (H:= @mod_hom_mkl _ _ _ R _ _ _ _ _ _  (Rec t)).
     simpl in H.
     rewrite H. auto.
Qed.

(** init_d is not only a monad morphism, but even a morphism
    of representations *)

Obligation Tactic := simpl; intros V x; try elim x; auto.

Program Instance Init_Rep_arrow : PCF_rep_Hom_struct (P:=PCF_PCF_rep)(R:=R)
     (Build_Monad_Hom Init_Rep_mor).
Next Obligation.
Proof.
  intro y;
  elim y. auto.
Qed.
Next Obligation.
Proof.
  intro y;
  elim y. auto.
Qed.

End monad_hom.

Section initial.

(**  PCF_PCF_rep is initial in the category PCF_REP *)

Obligation Tactic := idtac.

Program Instance PCF_rep_initial : Initial PCF_REP := {
  Init := PCF_PCF_rep;
  InitMor := fun a => Build_PCF_rep_Hom (Init_Rep_arrow a)
}.
Next Obligation.
Proof.
  intros b f.
  simpl.
  intros x t x0.
  generalize dependent f.
  generalize dependent b.
  induction x0; simpl; intros.
  set (H:= Bottom_Hom (PCF_rep_Hom_struct := f)).
  simpl in H.
  apply H.
  destruct c; simpl.
    set (H:= nats_Hom (PCF_rep_Hom_struct := f)n).
    simpl in H.
    apply H.
    set (H:= ttt_Hom (PCF_rep_Hom_struct := f)).
    simpl in H.
    apply H.
    set (H:= fff_Hom (PCF_rep_Hom_struct := f)).
    simpl in H.
    apply H.
    set (H:= succ_Hom (PCF_rep_Hom_struct := f)).
    simpl in H.
    apply H.
    set (H:= zero_Hom (PCF_rep_Hom_struct := f)).
    simpl in H.
    apply H.
    set (H:= condN_Hom (PCF_rep_Hom_struct := f)).
    simpl in H.
    apply H.
    set (H:= condB_Hom (PCF_rep_Hom_struct := f)).
    simpl in H.
    apply H.
  assert (H:=monad_hom_weta (Monad_Hom_struct := f)).
  simpl in H.
  apply H.
  set (H:= App_Hom (PCF_rep_Hom_struct := f)).
  simpl in H.
  rewrite <- (IHx0_1 b f).
  rewrite <- (IHx0_2 b f).
  apply (H _ _ _ (x0_1, x0_2)).

  rewrite <- (IHx0 b f).
  set (H:= Abs_Hom (PCF_rep_Hom_struct := f)).
  simpl in H.
  apply H.

  rewrite <- (IHx0 b f).
  set (H:= Rec_Hom (PCF_rep_Hom_struct := f)).
  simpl in H.
  apply H.

Qed.

End initial.

End initial_rep.


(** Authors: Jianzhou Zhao. *)

Require Export Bang_OParametricity_Pre.
Require Import Bang_Renaming.
Require Import Program.

Module Type IOParametricity.

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

Axiom ddom_gdom_disjoint : forall X x E,
  X `in` ddom_env E ->
  x `in` gdom_env E ->
  X <> x.

Axiom ddom_ldom_disjoint : forall X x E (lE:lenv),
  X `in` ddom_env E ->
  x `in` dom lE ->
  X <> x.

Definition admissible (E:env) (r : rel) : Prop :=
  (forall v v',
    r v v' ->
    (forall x y,
      x `in` (AtomSetImpl.diff (fv_ee v) (gdom_env E)) ->
      x `in` (AtomSetImpl.diff (fv_ee v') (gdom_env E)) ->
      y `notin` (AtomSetImpl.diff (fv_ee v  `union` fv_ee v' `union` dom E) {{x}}) ->
      r (subst_ee x y v) (subst_ee x y v')
    )
  ).

Definition wfor (E:env) (r : rel) (T T' : typ) : Prop :=
  (wf_typ E T) /\
  (wf_typ E T') /\
  admissible E r
  .

Axiom wfor_inv : forall E r T T',
  wfor E r T T'->
  (wf_typ E T) /\
  (wf_typ E T') /\
  admissible E r
  .

Axiom wfor_left_inv : forall E t t' R,
  wfor E R t t' -> wf_typ E t.

Axiom wfor_right_inv : forall E t t' R,
  wfor E R t t' -> wf_typ E t'.

Axiom wfor_renaming_inv : forall E r T T',
  wfor E r T T'->
  admissible E r
  .
(* ********************************************************************** *)
(** * Value Relations *)
Program Fixpoint F_Related_ovalues
    (t:typ) (rsubst:rho_subst)
    (dsubst dsubst':delta_subst) (v:exp) (v':exp) (Env:env) (lEnv:lenv) {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') /\ (admissible Env R) /\ (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') /\
    (exists L,
      (forall lEnv1 x x',
       typing Env lEnv1 x (apply_delta_subst_typ dsubst t1) ->
       typing Env lEnv1 x' (apply_delta_subst_typ dsubst' t1) ->
       wf_lenv Env (lEnv1++lEnv) ->
       disjdom L (dom lEnv1) ->
       (exists w, exists w',
        normalize x w /\ normalize x' w' /\
       F_Related_ovalues t1 rsubst dsubst dsubst' w w' Env lEnv1) ->
       (exists u, exists u',
        normalize (exp_app v x) u /\
        normalize (exp_app v' x') u' /\
        F_Related_ovalues t2 rsubst dsubst dsubst' u u' Env (lEnv1++lEnv))
      )
    )
  | 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),
          wfor Env 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_ovalues (open_tt t1 X)
                           ([(X,R)]++rsubst)
                           ([(X,t2)]++dsubst)
                           ([(X,t2')]++dsubst')
                            w w' Env lEnv)
        ))
      )
  | 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_ovalues t1 rsubst dsubst dsubst' u1 u1' Env lEnv)
    )
  | 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_ovalues t1 rsubst dsubst dsubst' u1 u1' Env lEnv) /\
      (exists u2, exists u2',
       normalize e2 u2 /\
       normalize e2' u2' /\
       F_Related_ovalues t2 rsubst dsubst dsubst' u2 u2' Env lEnv)
    )
  | _ => 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_oterms t rsubst (dsubst dsubst':delta_subst) e e' Env lEnv: Prop:=
    exists v, exists v',
    typing Env lEnv e (apply_delta_subst_typ dsubst t) /\
    typing Env lEnv e' (apply_delta_subst_typ dsubst' t) /\
    normalize e v /\
    normalize e' v' /\
    F_Related_ovalues t rsubst dsubst dsubst' v v' Env lEnv
  .

(** * Subst Relations *)
Inductive F_Related_osubst : env -> lenv -> gamma_subst -> gamma_subst -> gamma_subst -> gamma_subst -> rho_subst -> delta_subst -> delta_subst -> env -> lenv -> Prop:=
  | F_Related_osubst_empty :
    (*
      gamma_nil ~ gamma_nil : gempty | rho_nil, delta_nil,  delta_nil
    *)
    forall Env,
      wf_env Env ->
      F_Related_osubst nil nil gamma_nil gamma_nil gamma_nil gamma_nil rho_nil delta_nil delta_nil Env nil
  | F_Related_osubst_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) Env lEnv X R t t',
      F_Related_osubst E lE gsubst gsubst' lgsubst lgsubst' rsubst dsubst dsubst' Env lEnv ->
      X `notin` (fv_env E) `union` (fv_lenv lE) `union`  (fv_env Env) `union` (fv_lenv lEnv) ->
      wfor Env R t t' ->
      F_Related_osubst ([(X, bind_kn)]++E) lE gsubst gsubst' lgsubst lgsubst'
                                   ([(X,R)]++rsubst) ([(X,t)]++dsubst) ([(X,t')]++dsubst') Env lEnv
  | F_Related_osubst_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) Env lEnv (x:atom),
      F_Related_osubst E lE gsubst gsubst' lgsubst lgsubst' rsubst dsubst dsubst' Env lEnv ->
      typing Env lempty e (apply_delta_subst_typ dsubst t) ->
      typing Env lempty e' (apply_delta_subst_typ dsubst' t) ->
      F_Related_oterms t rsubst dsubst dsubst' e e' Env lempty ->
      x `notin` ((fv_env E) `union` (fv_lenv lE) `union` (fv_tt t)) `union`  (fv_env Env) `union` (fv_lenv lEnv) ->
      wf_typ E t ->
      F_Related_osubst ([(x, bind_typ t)]++E) lE
                   ([(x, e)]++gsubst) ([(x, e')]++gsubst') lgsubst lgsubst' rsubst dsubst dsubst' Env lEnv
  | F_Related_osubst_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) Env lEnv1 lEnv2 (x:atom),
      F_Related_osubst E lE gsubst gsubst' lgsubst lgsubst' rsubst dsubst dsubst' Env lEnv1 ->
      typing Env lEnv2 e (apply_delta_subst_typ dsubst t) ->
      typing Env lEnv2 e' (apply_delta_subst_typ dsubst' t) ->
      disjoint E lEnv2 /\ disjoint lE lEnv2 ->
      wf_lenv Env (lEnv2++lEnv1) ->
      F_Related_oterms t rsubst dsubst dsubst' e e' Env lEnv2 ->
      x `notin` ((fv_env E) `union` (fv_lenv lE) `union` (fv_tt t)) `union`  (fv_env Env) `union` (fv_lenv lEnv1) `union` (fv_lenv lEnv2) ->
      wf_typ E t ->
      F_Related_osubst E ([(x, lbind_typ t)]++lE)
                   gsubst gsubst' ([(x, e)]++lgsubst) ([(x, e')]++lgsubst') rsubst dsubst dsubst' Env (lEnv2++lEnv1)
      .

Tactic Notation "F_Related_osubst_cases" tactic(first) tactic(c) :=
  first;
  [ c "F_Related_osubst_empty" |
    c "F_Related_osubst_kind" |
    c "F_Related_osubst_typ" |
    c "F_Related_osubst_ltyp" ].

(** * Relations Subst *)
Inductive F_Rosubst : env-> rho_subst-> delta_subst -> delta_subst -> env -> Prop:=
  | F_Rosubst_empty :
    (*
      empty |- rho_nil \in delta_nil <-> delta_nil
    *)
    forall Env,
      wf_env Env ->
      F_Rosubst nil rho_nil delta_nil delta_nil Env
  | F_Rosubst_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) Env R t t' X,
      F_Rosubst E rsubst dsubst dsubst' Env ->
      wfor Env R t t' ->
      X `notin` (fv_env E) `union` (fv_env Env)->
      F_Rosubst ([(X, bind_kn)]++E) ([(X, R)]++rsubst) ([(X, t)]++dsubst) ([(X, t')]++dsubst') Env
  | F_Rosubst_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) Env x T,
      F_Rosubst E rsubst dsubst dsubst' Env ->
      wf_typ E T->
      x `notin` (fv_env E) `union` (fv_env Env)->
      F_Rosubst ([(x, bind_typ T)]++E) rsubst dsubst dsubst' Env
      .

Tactic Notation "F_Rosubst_cases" tactic(first) tactic(c) :=
  first;
  [ c "F_Rosubst_empty" |
    c "F_Rosubst_rel" |
    c "F_Rosubst_typ" ].

(** * SystemF Relations *)
Definition F_ORel t rsubst (dsubst dsubst':delta_subst) Env lEnv v v' :=
   typing Env lEnv v (apply_delta_subst_typ dsubst t) /\
   typing Env lEnv v' (apply_delta_subst_typ dsubst' t) /\
   F_Related_ovalues t rsubst dsubst dsubst' v v' Env lEnv
  .

(** * A Family of SystemF Relations *)
Definition F_FORel t rsubst (dsubst dsubst':delta_subst) Env v v' :=
   exists lEnv, F_ORel t rsubst dsubst dsubst' Env lEnv v v'
  .

Hint Constructors F_Related_osubst F_Rosubst.

(* ********************************************************************** *)
(* Fvalue simplification *)
Axiom F_Related_ovalues_bvar_eq: forall i (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp) Env lEnv,
  F_Related_ovalues (typ_bvar i) rsubst dsubst dsubst' v v' Env lEnv <-> False.

Axiom F_Related_ovalues_bvar_leq: forall i (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp) Env lEnv,
  F_Related_ovalues (typ_bvar i) rsubst dsubst dsubst' v v' Env lEnv -> False.

Axiom F_Related_ovalues_bvar_req: forall i (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp) Env lEnv,
  False ->
  F_Related_ovalues (typ_bvar i) rsubst dsubst dsubst' v v' Env lEnv.

Axiom F_Related_ovalues_fvar_eq: forall X (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp) Env lEnv,
  F_Related_ovalues (typ_fvar X) rsubst dsubst dsubst' v v' Env lEnv <->
    exists R,
      (binds X R rsubst) /\ (value v) /\ (value v') /\ (admissible Env R) /\ (R v v')
  .

Axiom F_Related_ovalues_fvar_leq: forall X  (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp) Env lEnv,
  F_Related_ovalues (typ_fvar X) rsubst dsubst dsubst' v v' Env lEnv ->
    exists R,
      (binds X R rsubst) /\ (value v) /\ (value v') /\ (admissible Env R) /\ (R v v')
  .

Axiom F_Related_ovalues_fvar_req: forall X  (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp) Env lEnv,
  (exists R,
    (binds X R rsubst) /\ (value v) /\ (value v') /\ (admissible Env R) /\ (R v v')) ->
  F_Related_ovalues (typ_fvar X) rsubst dsubst dsubst' v v' Env lEnv.

Axiom F_Related_ovalues_arrow_eq: forall (t1 t2:typ)  (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp) Env lEnv,
  F_Related_ovalues (typ_arrow t1 t2) rsubst dsubst dsubst' v v' Env lEnv
  <->
  (
    (value v) /\ (value v') /\
    (exists L,
      (forall lEnv1 x x',
       typing Env lEnv1 x (apply_delta_subst_typ dsubst t1) ->
       typing Env lEnv1 x' (apply_delta_subst_typ dsubst' t1) ->
       wf_lenv Env (lEnv1++lEnv) ->
       disjdom L (dom lEnv1) ->
       (exists w, exists w',
        normalize x w /\ normalize x' w' /\
       F_Related_ovalues t1 rsubst dsubst dsubst' w w' Env lEnv1) ->
       (exists u, exists u',
        normalize (exp_app v x) u /\
        normalize (exp_app v' x') u' /\
        F_Related_ovalues t2 rsubst dsubst dsubst' u u' Env (lEnv1++lEnv))
      )
    )
  )
   .

Axiom F_Related_ovalues_arrow_leq: forall (t1 t2:typ) (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp) Env lEnv,
  F_Related_ovalues (typ_arrow t1 t2) rsubst dsubst dsubst' v v' Env lEnv
  ->
  (
    (value v) /\ (value v') /\
    (exists L,
      (forall lEnv1 x x',
       typing Env lEnv1 x (apply_delta_subst_typ dsubst t1) ->
       typing Env lEnv1 x' (apply_delta_subst_typ dsubst' t1) ->
       wf_lenv Env (lEnv1++lEnv) ->
       disjdom L (dom lEnv1) ->
       (exists w, exists w',
        normalize x w /\ normalize x' w' /\
       F_Related_ovalues t1 rsubst dsubst dsubst' w w' Env lEnv1) ->
       (exists u, exists u',
        normalize (exp_app v x) u /\
        normalize (exp_app v' x') u' /\
        F_Related_ovalues t2 rsubst dsubst dsubst' u u' Env (lEnv1++lEnv))
      )
    )
  )
   .

Axiom F_Related_ovalues_arrow_req: forall (t1 t2:typ) (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp) Env lEnv,
  (
    (value v) /\ (value v') /\
    (exists L,
      (forall lEnv1 x x',
       typing Env lEnv1 x (apply_delta_subst_typ dsubst t1) ->
       typing Env lEnv1 x' (apply_delta_subst_typ dsubst' t1) ->
       wf_lenv Env (lEnv1++lEnv) ->
       disjdom L (dom lEnv1) ->
       (exists w, exists w',
        normalize x w /\ normalize x' w' /\
       F_Related_ovalues t1 rsubst dsubst dsubst' w w' Env lEnv1) ->
       (exists u, exists u',
        normalize (exp_app v x) u /\
        normalize (exp_app v' x') u' /\
        F_Related_ovalues t2 rsubst dsubst dsubst' u u' Env (lEnv1++lEnv))
      )
    )
  ) ->
  F_Related_ovalues (typ_arrow t1 t2) rsubst dsubst dsubst' v v' Env lEnv
   .

Axiom F_Related_ovalues_all_eq: forall (t1:typ) (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp) Env lEnv,
  F_Related_ovalues (typ_all t1) rsubst dsubst dsubst' v v' Env lEnv
  <->
      (
      (value v) /\ (value v') /\
      (exists L,
         (forall (X:atom) t2 t2' R (Fr:X `notin` L),
         wfor Env 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_ovalues (open_tt t1 X)
                           ([(X, R)]++rsubst)
                           ([(X, t2)]++dsubst)
                           ([(X, t2')]++dsubst')
                            w w' Env lEnv)
        ))
      )
  .

Axiom F_Related_ovalues_all_leq: forall (t1:typ) (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp) Env lEnv,
  F_Related_ovalues (typ_all t1) rsubst dsubst dsubst' v v' Env lEnv
  ->
      (
      (value v) /\ (value v') /\
      (exists L,
         (forall (X:atom) t2 t2' R (Fr:X `notin` L),
         wfor Env 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_ovalues (open_tt t1 X)
                           ([(X, R)]++rsubst)
                           ([(X, t2)]++dsubst)
                           ([(X, t2')]++dsubst')
                            w w' Env lEnv)
        ))
      )
  .

Axiom F_Related_ovalues_all_req: forall (t1:typ) (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp) Env lEnv,
      (
      (value v) /\ (value v') /\
      (exists L,
         (forall (X:atom) t2 t2' R (Fr:X `notin` L),
         wfor Env 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_ovalues (open_tt t1 X)
                           ([(X, R)]++rsubst)
                           ([(X, t2)]++dsubst)
                           ([(X, t2')]++dsubst')
                            w w' Env lEnv)
        ))
      )
  ->
  F_Related_ovalues (typ_all t1) rsubst dsubst dsubst' v v' Env lEnv
  .

Axiom F_Related_ovalues_bang_eq: forall (t1:typ) (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp) Env lEnv,
  F_Related_ovalues (typ_bang t1) rsubst dsubst dsubst' v v' Env lEnv
  <->
    (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_ovalues t1 rsubst dsubst dsubst' u1 u1' Env lEnv)
    )
   .

Axiom F_Related_ovalues_bang_leq: forall (t1:typ) (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp) Env lEnv,
  F_Related_ovalues (typ_bang t1) rsubst dsubst dsubst' v v' Env lEnv
  ->
    (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_ovalues t1 rsubst dsubst dsubst' u1 u1' Env lEnv)
    )
   .

Axiom F_Related_ovalues_bang_req: forall (t1:typ) (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp) Env lEnv,
    (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_ovalues t1 rsubst dsubst dsubst' u1 u1' Env lEnv)
    )
  ->
  F_Related_ovalues (typ_bang t1) rsubst dsubst dsubst' v v' Env lEnv
   .

Axiom F_Related_ovalues_with_eq: forall (t1 t2:typ) (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp) Env lEnv,
  F_Related_ovalues (typ_with t1 t2) rsubst dsubst dsubst' v v' Env lEnv
  <->
    (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_ovalues t1 rsubst dsubst dsubst' u1 u1' Env lEnv) /\
      (exists u2, exists u2',
       normalize e2 u2 /\
       normalize e2' u2' /\
       F_Related_ovalues t2 rsubst dsubst dsubst' u2 u2' Env lEnv)
    )
   .

Axiom F_Related_ovalues_with_leq: forall (t1 t2:typ) (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp) Env lEnv,
  F_Related_ovalues (typ_with t1 t2) rsubst dsubst dsubst' v v' Env lEnv
  ->
    (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_ovalues t1 rsubst dsubst dsubst' u1 u1' Env lEnv) /\
      (exists u2, exists u2',
       normalize e2 u2 /\
       normalize e2' u2' /\
       F_Related_ovalues t2 rsubst dsubst dsubst' u2 u2' Env lEnv)
    )
   .

Axiom F_Related_ovalues_with_req: forall (t1 t2:typ) (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp) Env lEnv,
    (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_ovalues t1 rsubst dsubst dsubst' u1 u1' Env lEnv) /\
      (exists u2, exists u2',
       normalize e2 u2 /\
       normalize e2' u2' /\
       F_Related_ovalues t2 rsubst dsubst dsubst' u2 u2' Env lEnv)
    )
  ->
  F_Related_ovalues (typ_with t1 t2) rsubst dsubst dsubst' v v' Env lEnv
   .

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

Axiom F_Related_ovalues_inversion: forall t v v' rsubst dsubst dsubst' Env lEnv,
  F_Related_ovalues t rsubst dsubst dsubst' v v' Env lEnv ->
  ((value v)* (value v'))%type.

Axiom F_Rosubst__wf_osubst:
  forall (E:env) (rsubst:rho_subst) (dsubst:delta_subst) (dsubst':delta_subst) Env,
  F_Rosubst E rsubst dsubst dsubst' Env ->
  ((wf_delta_osubst E dsubst Env) * (wf_delta_osubst E dsubst' Env) * (wf_rho_subst E rsubst))%type.

Axiom Forel_inversion: forall t rsubst dsubst dsubst' v v' Env lEnv,
  F_ORel t rsubst dsubst dsubst' Env lEnv v v' ->
  ((value v)* (value v'))%type.

Axiom Fforel_inversion: forall t rsubst dsubst dsubst' v v' Env,
  F_FORel t rsubst dsubst dsubst' Env v v' ->
  ((value v)* (value v'))%type.

Axiom F_Related_osubst__inversion:
  forall (E:env) (lE:lenv) (rsubst:rho_subst) (dsubst:delta_subst) (dsubst':delta_subst) gsubst gsubst' lgsubst lgsubst' Env lEnv,
  F_Related_osubst E lE gsubst gsubst' lgsubst lgsubst' rsubst dsubst dsubst' Env lEnv ->
  ((wf_delta_osubst E dsubst Env) * (wf_delta_osubst E dsubst' Env) *
   (wf_lgamma_osubst E lE dsubst gsubst lgsubst Env lEnv)* (wf_lgamma_osubst E lE dsubst' gsubst' lgsubst' Env lEnv) *
   (wf_rho_subst E rsubst) * (wf_env E) * (wf_lenv E lE) * (wf_env Env) * (wf_lenv Env lEnv))%type.

(*******************************************************************************)
(** Renaming *)

Axiom Forel_lin_renaming : forall t rsubst dsubst dsubst' e e' E Env lEnv x0 y0,
  F_Related_ovalues t rsubst dsubst dsubst' e e' Env lEnv ->
  wf_rho_subst E rsubst ->
  wf_delta_osubst E dsubst Env ->
  wf_delta_osubst E dsubst' Env ->
  typing Env lEnv e (apply_delta_subst_typ dsubst t) ->
  typing Env lEnv e' (apply_delta_subst_typ dsubst' t) ->
  x0 `notin` dom Env ->
  y0 `notin` dom Env `union` dom lEnv ->
  F_Related_ovalues t rsubst dsubst dsubst' (subst_ee x0 y0 e) (subst_ee x0 y0 e') Env (subst_atom_lenv lEnv x0 y0).

Axiom Forel_lin_renamings : forall t rsubst dsubst dsubst' e e' E Env lEnv asubst,
  F_Related_ovalues t rsubst dsubst dsubst' e e' Env lEnv ->
  wf_rho_subst E rsubst ->
  wf_delta_osubst E dsubst Env ->
  wf_delta_osubst E dsubst' Env ->
  typing Env lEnv e (apply_delta_subst_typ dsubst t) ->
  typing Env lEnv e' (apply_delta_subst_typ dsubst' t) ->
  wf_atom_subst asubst ->
  disjoint asubst Env ->
  disjdom (atom_subst_codom asubst) (dom Env `union` dom lEnv) ->
  F_Related_ovalues t rsubst dsubst dsubst' (subst_atoms_exp asubst e) (subst_atoms_exp asubst e') Env (subst_atoms_lenv asubst lEnv).

(*******************************************************************************)
(** Reverse Renaming *)

Axiom Forel_lin_rev_renamings : forall t rsubst dsubst dsubst' e e' E Env lEnv asubst,
  F_Related_ovalues t rsubst dsubst dsubst' e e' Env lEnv ->
  wf_rho_subst E rsubst ->
  wf_delta_osubst E dsubst Env ->
  wf_delta_osubst E dsubst' Env ->
  typing Env lEnv e (apply_delta_subst_typ dsubst t) ->
  typing Env lEnv e' (apply_delta_subst_typ dsubst' t) ->
  wf_atom_subst asubst ->
  disjdom (atom_subst_codom asubst) (dom Env) ->
  disjdom (dom asubst) (dom Env `union` dom lEnv) ->
  F_Related_ovalues t rsubst dsubst dsubst' (rev_subst_atoms_exp asubst e) (rev_subst_atoms_exp asubst e') Env (rev_subst_atoms_lenv asubst lEnv).

(*******************************************************************************)
(** Dom Equal *)

Axiom Forel_lin_domeq : forall t rsubst dsubst dsubst' e e' Env lEnv lEnv',
  F_Related_ovalues t rsubst dsubst dsubst' e e' Env lEnv ->
  wf_lenv Env lEnv ->
  dom lEnv [=] dom lEnv' ->
  F_Related_ovalues t rsubst dsubst dsubst' e e' Env lEnv'.

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

Axiom Forel_weaken:  forall t E E' v v' rsubst rsubst' dsubst dsubst' dsubst0 dsubst'0 Env lEnv X R t2 t2',
  ((F_Related_ovalues t (rsubst'++rsubst) (dsubst0++dsubst) (dsubst'0++dsubst') v v' Env lEnv ->
  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) `union` fv_env Env `union` fv_lenv lEnv)->
  wf_typ Env t2 ->
  wf_typ Env t2' ->
  wf_rho_subst (E'++E) (rsubst'++rsubst) ->
  wf_delta_osubst (E'++E) (dsubst0++dsubst) Env ->
  wf_delta_osubst (E'++E) (dsubst'0++dsubst') Env ->
  F_Related_ovalues t (rsubst'++[(X, R)]++rsubst) (dsubst0++[(X, t2)]++dsubst) (dsubst'0++[(X, t2')]++dsubst') v v' Env lEnv))
  .

Axiom Forel_weaken_head:  forall t E v v' rsubst dsubst dsubst' Env lEnv X R t2 t2',
  ((F_Related_ovalues t rsubst dsubst dsubst' v v' Env lEnv ->
  ddom_env E [=] dom dsubst ->
  ddom_env E [=] dom dsubst' ->
  ddom_env E [=] dom rsubst ->
  X `notin` (fv_env E `union` (fv_tt t) `union` fv_env Env `union` fv_lenv lEnv)->
  wf_typ Env t2 ->
  wf_typ Env t2' ->
  wf_rho_subst E rsubst ->
  wf_delta_osubst E dsubst Env ->
  wf_delta_osubst E dsubst' Env ->
  F_Related_ovalues t ([(X, R)]++rsubst) ([(X, t2)]++dsubst) ([(X, t2')]++dsubst') v v' Env lEnv))
  .

Axiom Forel_stronger:  forall t E E' v v' rsubst rsubst' dsubst dsubst' dsubst0 dsubst'0 Env lEnv X R t2 t2',
  F_Related_ovalues t (rsubst'++[(X,R)]++rsubst) (dsubst0++[(X,t2)]++dsubst) (dsubst'0++[(X,t2')]++dsubst') v v' Env lEnv ->
  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) `union` fv_env Env `union` fv_lenv lEnv)->
  wf_typ Env t2 ->
  wf_typ Env t2' ->
  wf_rho_subst (E'++[(X,bind_kn)]++E) (rsubst'++[(X,R)]++rsubst) ->
  wf_delta_osubst (E'++[(X,bind_kn)]++E) (dsubst0++[(X,t2)]++dsubst) Env ->
  wf_delta_osubst (E'++[(X,bind_kn)]++E) (dsubst'0++[(X,t2')]++dsubst') Env ->
  F_Related_ovalues t (rsubst'++rsubst) (dsubst0++dsubst) (dsubst'0++dsubst') v v' Env lEnv
  .

Axiom bindosgE__bindosgsubst: forall E lE gsubst gsubst' lgsubst lgsubst' rsubst dsubst dsubst' Env lEnv x T,
    F_Related_osubst E lE gsubst gsubst' lgsubst lgsubst' rsubst dsubst dsubst' Env lEnv ->
    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 Env lempty e (apply_delta_subst_typ dsubst T))*(typing Env lempty e' (apply_delta_subst_typ dsubst' T))
                *(F_Related_oterms T rsubst dsubst dsubst' e e' Env lempty))%type)
    .

Axiom lbindosgE__lbindosgsubst: forall E gsubst gsubst' lgsubst lgsubst' rsubst dsubst dsubst' Env lEnv x T,
    F_Related_osubst E [(x, lbind_typ T)] gsubst gsubst' lgsubst lgsubst' rsubst dsubst dsubst' Env lEnv ->
    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 Env lEnv e (apply_delta_subst_typ dsubst T))*(typing Env lEnv e' (apply_delta_subst_typ dsubst' T))
                *(F_Related_oterms T rsubst dsubst dsubst' e e' Env lEnv))%type)
    .

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

Definition F_ORel__R (t:typ) (E:env) (rsubst:rho_subst) dsubst dsubst' Env lEnv (R:rel) :=
  wf_delta_osubst E dsubst Env /\  wf_delta_osubst E dsubst' Env /\  wf_rho_subst E rsubst /\
  (forall v v',
    ((F_ORel t rsubst dsubst dsubst' Env lEnv v v' -> R v v')
   * (R v v'->F_ORel t rsubst dsubst dsubst' Env lEnv v v')) % type)
  .

Definition F_FORel__R (t:typ) (E:env) (rsubst:rho_subst) dsubst dsubst' Env (R:rel) :=
  wf_delta_osubst E dsubst Env /\  wf_delta_osubst E dsubst' Env /\  wf_rho_subst E rsubst /\
  (forall v v',
    ((F_FORel t rsubst dsubst dsubst' Env v v' -> R v v')
   * (R v v'->F_FORel t rsubst dsubst dsubst' Env v v')) % type)
  .

Axiom F_FORel__R__wfor: forall (E:env) (t:typ) (rsubst:rho_subst) dsubst dsubst' Env (R:rel),
  F_FORel__R t E rsubst dsubst dsubst' Env R ->
  wf_typ E t ->
  wfor Env R (apply_delta_subst_typ dsubst t) (apply_delta_subst_typ dsubst' t).

Axiom oparametricity_subst_value : forall t E E' e e' rsubst rsubst' dsubst dsubst' dsubst0 dsubst'0 Env lEnv 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_FORel__R t2 (E'++E) (rsubst'++rsubst) (dsubst0++dsubst) (dsubst'0++dsubst') Env R ->
  X `notin` (fv_env E `union` fv_env E' `union` (fv_tt t) `union` (fv_te e) `union` (fv_te e') `union` fv_env Env `union` fv_lenv lEnv)->
  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_ovalues (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' Env lEnv ->
  typing Env lEnv e (apply_delta_subst_typ (dsubst0++[(X,(apply_delta_subst_typ (dsubst0++dsubst) t2))]++dsubst) (open_tt_rec k (typ_fvar X) t)) ->
  typing Env lEnv e' (apply_delta_subst_typ (dsubst'0++[(X,(apply_delta_subst_typ (dsubst'0++dsubst') t2))]++dsubst') (open_tt_rec k (typ_fvar X) t)) ->
  wf_rho_subst (E'++[(X, bind_kn)]++E) (rsubst'++[(X, R)]++rsubst) ->
  wf_delta_osubst (E'++[(X, bind_kn)]++E) (dsubst0++[(X, (apply_delta_subst_typ (dsubst0++dsubst) t2))]++dsubst) Env ->
  wf_delta_osubst (E'++[(X, bind_kn)]++E) (dsubst'0++[(X, (apply_delta_subst_typ (dsubst'0++dsubst') t2))]++dsubst') Env ->
  F_Related_ovalues (open_tt_rec k t2 t) (rsubst'++rsubst) (dsubst0++dsubst) (dsubst'0++dsubst') e e' Env lEnv)
  .

(*******************************************************************************)
(** F_Related_osubst_split *)

Axiom F_Related_osubst_split: forall E lE lE1 lE2 dsubst dsubst' gsubst gsubst' lgsubst lgsubst' rsubst Env lEnv,
   F_Related_osubst E lE gsubst gsubst' lgsubst lgsubst' rsubst dsubst dsubst' Env lEnv ->
   lenv_split E lE1 lE2 lE ->
   exists lgsubst1, exists lgsubst1', exists lgsubst2, exists lgsubst2', exists lEnv1, exists lEnv2,
     lgamma_osubst_split E lE dsubst gsubst lgsubst1 lgsubst2 lgsubst Env lEnv1 lEnv2 lEnv /\
     lgamma_osubst_split E lE dsubst' gsubst' lgsubst1' lgsubst2' lgsubst' Env lEnv1 lEnv2 lEnv  /\
     F_Related_osubst E lE1 gsubst gsubst' lgsubst1 lgsubst1' rsubst dsubst dsubst' Env lEnv1 /\
     F_Related_osubst E lE2 gsubst gsubst' lgsubst2 lgsubst2' rsubst dsubst dsubst' Env lEnv2.

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

Axiom oparametricity: forall E lE e t dsubst dsubst' gsubst gsubst' lgsubst lgsubst' rsubst Env lEnv,
   typing E lE e t ->
   F_Related_osubst E lE gsubst gsubst' lgsubst lgsubst' rsubst dsubst dsubst' Env lEnv ->
   F_Rosubst E rsubst dsubst dsubst' Env->
   F_Related_oterms 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)))
                                 Env lEnv
   .

End IOParametricity.

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