(* Full safety for F-sub (WIP) *)
(* values well-typed with respect to runtime environment *)
(* inversion lemma structure *)

(* this version adds bottom and lower bounds to fsub0.v *)

(*
TODO:
- stp2 trans + narrowing
- stp/stp2 weakening and regularity
*)

Require Export SfLib.

Require Export Arith.EqNat.
Require Export Arith.Le.

Module FSUB.

Definition id := nat.

Inductive ty : Type :=
  | TBool  : ty
  | TBot   : ty
  | TTop   : ty
  | TFun   : ty -> ty -> ty
  | TMem   : ty -> ty -> ty
  | TSel   : id -> ty
  | TSelH  : id -> ty
  | TSelB  : id -> ty
  | TAll   : ty -> ty -> ty
.

Inductive tm : Type :=
  | ttrue  : tm
  | tfalse : tm
  | tvar   : id -> tm
  | tapp   : tm -> tm -> tm (* f(x) *)
  | tabs   : id -> id -> tm -> tm (* \f x.y *)
  | ttapp  : tm -> ty -> tm (* f[X] *)
  | ttabs  : id -> ty -> tm -> tm (* \f x.y *)
.

Inductive vl : Type :=
| vty   : list (id*vl) -> ty -> vl
| vtya  : list (id*vl) -> ty -> vl (* X<T, only used in stp2_all *)
| vbool : bool -> vl
| vabs  : list (id*vl) -> id -> id -> tm -> vl
| vtabs : list (id*vl) -> id -> ty -> tm -> vl
.

Definition tenv := list (id*ty).
Definition venv := list (id*vl).
Definition aenv := list (id*(venv*ty)).

Hint Unfold venv.
Hint Unfold tenv.

Fixpoint fresh {X: Type} (l : list (id * X)): nat :=
  match l with
    | [] => 0
    | (n',a)::l' => 1 + n'
  end.

Fixpoint index {X : Type} (n : id) (l : list (id * X)) : option X :=
  match l with
    | [] => None
    | (n',a) :: l'  =>
      if le_lt_dec (fresh l') n' then
        if (beq_nat n n') then Some a else index n l'
      else None
  end.

Fixpoint indexr {X : Type} (n : id) (l : list (id * X)) : option X :=
  match l with
    | [] => None
    | (n',a) :: l'  => (* DeBrujin *)
      if (beq_nat n (length l')) then Some a else indexr n l'
  end.

(*
Fixpoint update {X : Type} (n : nat) (x: X)
               (l : list X) { struct l }: list X :=
  match l with
    | [] => []
    | a :: l'  => if beq_nat n (length l') then x::l' else a :: update n x l'
  end.
*)

(* LOCALLY NAMELESS *)

Inductive closed_rec: nat -> nat -> ty -> Prop :=
| cl_top: forall k l,
    closed_rec k l TTop
| cl_bot: forall k l,
    closed_rec k l TBot
| cl_bool: forall k l,
    closed_rec k l TBool
| cl_fun: forall k l T1 T2,
    closed_rec k l T1 ->
    closed_rec k l T2 ->
    closed_rec k l (TFun T1 T2)
| cl_mem: forall k l T1 T2,
    closed_rec k l T1 ->
    closed_rec k l T2 ->
    closed_rec k l (TMem T1 T2)
| cl_bind: forall k l T1 T2,
    closed_rec k l T1 ->
    closed_rec (S k) l T2 ->
    closed_rec k l (TAll T1 T2)
| cl_sel: forall k l x,
    closed_rec k l (TSel x)
| cl_selh: forall k l x,
    l > x ->
    closed_rec k l (TSelH x)
| cl_selb: forall k l i,
    k > i ->
    closed_rec k l (TSelB i)
.

Hint Constructors closed_rec.

Definition closed j l T := closed_rec j l T.

Fixpoint open_rec (k: nat) (u: ty) (T: ty) { struct T }: ty :=
  match T with
    | TSel x      => TSel x (* free var remains free. functional, so we can't check for conflict *)
    | TSelH i     => TSelH i (*if beq_nat k i then u else TSelH i *)
    | TSelB i     => if beq_nat k i then u else TSelB i
    | TAll T1 T2  => TAll (open_rec k u T1) (open_rec (S k) u T2)
    | TTop        => TTop
    | TBot        => TBot
    | TBool       => TBool
    | TMem T1 T2  => TMem (open_rec k u T1) (open_rec k u T2)
    | TFun T1 T2  => TFun (open_rec k u T1) (open_rec k u T2)
  end.

Definition open u T := open_rec 0 u T.

(* sanity check *)
Example open_ex1: open (TSel 9) (TAll TBool (TFun (TSelB 1) (TSelB 0))) =
                      (TAll TBool (TFun (TSel 9) (TSelB 0))).
Proof. compute. eauto. Qed.

Fixpoint subst (U : ty) (T : ty) {struct T} : ty :=
  match T with
    | TTop         => TTop
    | TBot         => TBot
    | TBool        => TBool
    | TMem T1 T2   => TMem (subst U T1) (subst U T2)
    | TFun T1 T2   => TFun (subst U T1) (subst U T2)
    | TSelB i      => TSelB i
    | TSel i       => TSel i
    | TSelH i      => if beq_nat i 0 then U else TSelH (i-1)
    | TAll T1 T2   => TAll (subst U T1) (subst U T2)
  end.

Fixpoint nosubst (T : ty) {struct T} : Prop :=
  match T with
    | TTop         => True
    | TBot         => True
    | TBool        => True
    | TMem T1 T2   => nosubst T1 /\ nosubst T2
    | TFun T1 T2   => nosubst T1 /\ nosubst T2
    | TSelB i      => True
    | TSel i       => True
    | TSelH i      => i <> 0
    | TAll T1 T2   => nosubst T1 /\ nosubst T2
  end.

Hint Unfold open.
Hint Unfold closed.

Inductive stp: tenv -> tenv -> ty -> ty -> Prop :=
| stp_top: forall G1 GH T1,
    stp G1 GH T1 TTop
| stp_bot: forall G1 GH T2,
    stp G1 GH TBot T2
| stp_bool: forall G1 GH,
    stp G1 GH TBool TBool
| stp_fun: forall G1 GH T1 T2 T3 T4,
    stp G1 GH T3 T1 ->
    stp G1 GH T2 T4 ->
    stp G1 GH (TFun T1 T2) (TFun T3 T4)
| stp_mem: forall G1 GH T1 T2 T3 T4,
    stp G1 GH T3 T1 ->
    stp G1 GH T2 T4 ->
    stp G1 GH (TMem T1 T2) (TMem T3 T4)
| stp_sel1: forall G1 GH TL TU T2 x,
    index x G1 = Some (TMem TL TU) ->
    stp G1 GH TU T2 ->
    stp G1 GH (TSel x) T2
| stp_sel2: forall G1 GH TL TU T1 x,
    index x G1 = Some (TMem TL TU) ->
    stp G1 GH T1 TL ->
    stp G1 GH T1 (TSel x)
| stp_selx: forall G1 GH TL TU x,
    index x G1 = Some (TMem TL TU) ->
    stp G1 GH (TSel x) (TSel x)
| stp_sela1: forall G1 GH TL TU T2 x,
    indexr x GH = Some (TMem TL TU) ->
    stp G1 GH TU T2 ->
    stp G1 GH (TSelH x) T2
| stp_sela2: forall G1 GH TL TU T1 x,
    indexr x GH = Some (TMem TL TU) ->
    stp G1 GH T1 TL ->
    stp G1 GH T1 (TSelH x)
| stp_selax: forall G1 GH TL TU x,
    indexr x GH = Some (TMem TL TU) ->
    stp G1 GH (TSelH x) (TSelH x)
| stp_all: forall G1 GH T1 T2 T3 T4 x,
    stp G1 GH T3 T1 ->
    x = length GH ->
    closed 1 (length GH) T2 -> (* must not accidentally bind x *)
    closed 1 (length GH) T4 ->
    stp G1 ((0,T3)::GH) (open (TSelH x) T2) (open (TSelH x) T4) ->
    stp G1 GH (TAll T1 T2) (TAll T3 T4)
.

Hint Constructors stp.

(* TODO *)

Inductive has_type : tenv -> tm -> ty -> Prop :=
| t_true: forall env,
           has_type env ttrue TBool
| t_false: forall env,
           has_type env tfalse TBool
| t_var: forall x env T1,
           index x env = Some T1 ->
           stp env [] T1 T1 ->
           has_type env (tvar x) T1
| t_app: forall env f x T1 T2,
           has_type env f (TFun T1 T2) ->
           has_type env x T1 ->
           has_type env (tapp f x) T2
| t_abs: forall env f x y T1 T2,
           has_type ((x,T1)::(f,TFun T1 T2)::env) y T2 ->
           stp env [] (TFun T1 T2) (TFun T1 T2) ->
           fresh env <= f ->
           1+f <= x ->
           has_type env (tabs f x y) (TFun T1 T2)
| t_tapp: forall env f T11 T12,
           has_type env f (TAll (TMem T11 T11) T12) ->
           (* T = open T11 T12 -> *)
           stp env [] T12 T12 ->
           has_type env (ttapp f T11) T12
(*
NOTE: both the POPLmark paper and Cardelli's paper use this rule:
Does it make a difference? It seems like we can always widen f?

| t_tapp: forall env f T2 T11 T12 ,
           has_type env f (TAll T11 T12) ->
           stp env T2 T11 ->
           has_type env (ttapp f T2) (open T2 T12)

*)
| t_tabs: forall env x y T1 T2,
           has_type ((x,T1)::env) y (open (TSel x) T2) ->
           stp env [] (TAll T1 T2) (TAll T1 T2) ->
           fresh env = x ->
           has_type env (ttabs x T1 y) (TAll T1 T2)

| t_sub: forall env e T1 T2,
           has_type env e T1 ->
           stp env [] T1 T2 ->
           has_type env e T2
.

Inductive stp2: venv -> ty -> venv -> ty -> list (id*(venv*ty))  -> Prop :=
| stp2_top: forall G1 G2 GH T,
    stp2 G1 T G2 TTop GH
| stp2_bot: forall G1 G2 GH T,
    stp2 G1 TBot G2 T GH
| stp2_bool: forall G1 G2 GH,
    stp2 G1 TBool G2 TBool GH
| stp2_fun: forall G1 G2 T1 T2 T3 T4 GH,
    stp2 G2 T3 G1 T1 GH ->
    stp2 G1 T2 G2 T4 GH ->
    stp2 G1 (TFun T1 T2) G2 (TFun T3 T4) GH
| stp2_mem: forall G1 G2 T1 T2 T3 T4 GH,
    stp2 G2 T3 G1 T1 GH ->
    stp2 G1 T2 G2 T4 GH ->
    stp2 G1 (TMem T1 T2) G2 (TMem T3 T4) GH

(* we do not require TMem TX here, just TX -- the vty is marker enough *)
(* atm not clear if these are needed *)
| stp2_sel1: forall G1 G2 GX TX x T2 GH,
    index x G1 = Some (vty GX TX) ->
    closed 0 0 TX ->
    stp2 GX TX G2 T2 GH ->
    stp2 G1 (TSel x) G2 T2 GH

| stp2_sel2: forall G1 G2 GX TX x T1 GH,
    index x G2 = Some (vty GX TX) ->
    closed 0 0 TX ->
    stp2 G1 T1 GX TX GH ->
    stp2 G1 T1 G2 (TSel x) GH

(* X<T, one sided *)
| stp2_sela1: forall G1 G2 GX TL TU x T2 GH,
    indexr x GH = Some (GX, (TMem TL TU)) ->
    (* closed 0 x TX -> *)
    stp2 GX TU G2 T2 GH ->
    stp2 G1 (TSelH x) G2 T2 GH

| stp2_selax: forall G1 G2 GX TX x GH,
    indexr x GH = Some (GX, TX) ->
    indexr x GH = Some (GX, TX) ->
    (*closed 0 x TX ->*)
    stp2 G1 (TSelH x) G2 (TSelH x) GH

| stp2_all: forall G1 G2 T1 T2 T3 T4 GH,
    stp2 G2 T3 G1 T1 GH ->
    closed 1 (length GH) T2 -> (* must not accidentally bind x *)
    closed 1 (length GH) T4 ->
    stp2 G1 (open (TSelH (length GH)) T2) G2 (open (TSelH (length GH)) T4) ((0,(G2, T3))::GH) ->
    stp2 G1 (TAll T1 T2) G2 (TAll T3 T4) GH
.

Inductive wf_env : venv -> tenv -> Prop :=
| wfe_nil : wf_env nil nil
| wfe_cons : forall n v t vs ts,
    val_type ((n,v)::vs) v t ->
    wf_env vs ts ->
    wf_env (cons (n,v) vs) (cons (n,t) ts)

with val_type : venv -> vl -> ty -> Prop :=
| v_ty: forall env venv tenv T1 TE,
    wf_env venv tenv -> (* T1 wf in tenv ? *)
    stp2 venv (TMem T1 T1) env TE [] ->
    val_type env (vty venv T1) TE
| v_bool: forall venv b TE,
    stp2 [] TBool venv TE [] ->
    val_type venv (vbool b) TE
| v_abs: forall env venv tenv f x y T1 T2 TE,
    wf_env venv tenv ->
    has_type ((x,T1)::(f,TFun T1 T2)::tenv) y T2 ->
    fresh venv <= f ->
    1 + f <= x ->
    stp2 venv (TFun T1 T2) env TE [] ->
    val_type env (vabs venv f x y) TE
| v_tabs: forall env venv tenv x y T1 T2 TE,
    wf_env venv tenv ->
    has_type ((x,T1)::tenv) y (open (TSel x) T2) ->
    fresh venv = x ->
    stp2 venv (TAll T1 T2) env TE [] ->
    val_type env (vtabs venv x T1 y) TE
.

Inductive wf_envh : venv -> aenv -> tenv -> Prop :=
| wfeh_nil : forall vvs, wf_envh vvs nil nil
| wfeh_cons : forall n t vs vvs ts,
    wf_envh vvs vs ts ->
    wf_envh vvs (cons (n,(vvs,t)) vs) (cons (n,t) ts)
.

Inductive valh_type : venv -> aenv -> (venv*ty) -> ty -> Prop :=
| v_tya: forall aenv venv T1,
    valh_type venv aenv (venv, T1) T1
.

(*
None             means timeout
Some None        means stuck
Some (Some v))   means result v

Could use do-notation to clean up syntax.
 *)

Fixpoint teval(n: nat)(env: venv)(t: tm){struct n}: option (option vl) :=
  match n with
    | 0 => None
    | S n =>
      match t with
        | ttrue      => Some (Some (vbool true))
        | tfalse     => Some (Some (vbool false))
        | tvar x     => Some (index x env)
        | tabs f x y => Some (Some (vabs env f x y))
        | ttabs x T y  => Some (Some (vtabs env x T y))
        | tapp ef ex   =>
          match teval n env ex with
            | None => None
            | Some None => Some None
            | Some (Some vx) =>
              match teval n env ef with
                | None => None
                | Some None => Some None
                | Some (Some (vbool _)) => Some None
                | Some (Some (vty _ _)) => Some None
                | Some (Some (vtya _ _)) => Some None
                | Some (Some (vtabs _ _ _ _)) => Some None
                | Some (Some (vabs env2 f x ey)) =>
                  teval n ((x,vx)::(f,vabs env2 f x ey)::env2) ey
              end
          end
        | ttapp ef ex   =>
          match teval n env ef with
            | None => None
            | Some None => Some None
            | Some (Some (vbool _)) => Some None
            | Some (Some (vty _ _)) => Some None
            | Some (Some (vtya _ _)) => Some None
            | Some (Some (vabs _ _ _ _)) => Some None
            | Some (Some (vtabs env2 x T ey)) =>
              teval n ((x,vty env ex)::env2) ey
          end
      end
  end.

Hint Constructors ty.
Hint Constructors tm.
Hint Constructors vl.

Hint Constructors closed_rec.
Hint Constructors has_type.
Hint Constructors val_type.
Hint Constructors wf_env.
Hint Constructors stp.
Hint Constructors stp2.

Hint Constructors option.
Hint Constructors list.

Hint Unfold index.
Hint Unfold length.
Hint Unfold closed.
Hint Unfold open.

Hint Resolve ex_intro.

(* ############################################################ *)
(* Examples *)
(* ############################################################ *)

(*
match goal with
        | |- has_type _ (tvar _) _ =>
          try solve [apply t_vara;
                      repeat (econstructor; eauto)]
          | _ => idtac
      end;
*)

Ltac crush_has_tp :=
  try solve [eapply stp_selx; compute; eauto; crush_has_tp];
  try solve [eapply stp_selax; compute; eauto; crush_has_tp];
  try solve [eapply cl_selb; compute; eauto; crush_has_tp];
  try solve [(econstructor; compute; eauto; crush_has_tp)].

Ltac crush2 :=
  try solve [(eapply stp_selx; compute; eauto; crush2)];
  try solve [(eapply stp_selax; compute; eauto; crush2)];
  try solve [(eapply stp_sel1; compute; eauto; crush2)];
  try solve [(eapply stp_sela1; compute; eauto; crush2)];
  try solve [(eapply cl_selb; compute; eauto; crush2)];
  try solve [(econstructor; compute; eauto; crush2)];
  try solve [(eapply t_sub; eapply t_var; compute; eauto; crush2)].

(* define polymorphic identity function *)

Definition polyId := TAll (TMem TBot TTop) (TFun (TSelB 0) (TSelB 0)).

Example ex1: has_type [] (ttabs 0 (TMem TBot TTop) (tabs 1 2 (tvar 2))) polyId.
Proof.
  crush2.
Qed.

(* instantiate it to bool *)

Example ex2: has_type [(0,polyId)] (ttapp (tvar 0) TBool) (TFun TBool TBool).
Proof.
  eapply t_tapp. eapply t_sub. eapply t_var. simpl. eauto.
  eapply stp_all. eauto. eauto.
  crush_has_tp.  crush_has_tp.   crush_has_tp. compute.

  eapply stp_all. crush2. crush2. crush2. crush2. crush2. crush2.
Qed.

(* define brand / unbrand client function *)

Definition brandUnbrand :=
  TAll (TMem TBot TTop)
       (TFun
          (TFun TBool (TSelB 0)) (* brand *)
          (TFun
             (TFun (TSelB 0) TBool) (* unbrand *)
             TBool)).

Example ex3:
  has_type []
           (ttabs 0 (TMem TBot TTop)
                  (tabs 1 2
                        (tabs 3 4
                              (tapp (tvar 4) (tapp (tvar 2) ttrue)))))
           brandUnbrand.
Proof.
  crush2.
Qed.

(* instantiating it at bool is admissible *)

Example ex4:
  has_type [(1,TFun TBool TBool);(0,brandUnbrand)]
           (tvar 0) (TAll (TMem TBool TBool) (TFun (TFun TBool TBool) (TFun (TFun TBool TBool) TBool))).
Proof.
  eapply t_sub. crush2. crush2.
Qed.

Hint Resolve ex4.

(* apply it to identity functions *)

Example ex5:
  has_type [(1,TFun TBool TBool);(0,brandUnbrand)]
           (tapp (tapp (ttapp (tvar 0) TBool) (tvar 1)) (tvar 1)) TBool.
Proof.
  crush2.
Qed.

(* ############################################################ *)
(* Proofs *)
(* ############################################################ *)

Lemma wf_fresh : forall vs ts,
                    wf_env vs ts ->
                    (fresh vs = fresh ts).
Proof.
  intros. induction H. auto.
  compute. eauto.
Qed.

Hint Immediate wf_fresh.

Lemma wfh_length : forall vvs vs ts,
                    wf_envh vvs vs ts ->
                    (length vs = length ts).
Proof.
  intros. induction H. auto.
  compute. eauto.
Qed.

Hint Immediate wf_fresh.

Lemma index_max : forall X vs n (T: X),
                       index n vs = Some T ->
                       n < fresh vs.
Proof.
  intros X vs. induction vs.
  - Case "nil". intros. inversion H.
  - Case "cons".
    intros. inversion H. destruct a.
    case_eq (le_lt_dec (fresh vs) i); intros ? E1.
    + SCase "ok".
      rewrite E1 in H1.
      case_eq (beq_nat n i); intros E2.
      * SSCase "hit".
        eapply beq_nat_true in E2. subst n. compute. eauto.
      * SSCase "miss".
        rewrite E2 in H1.
        assert (n < fresh vs). eapply IHvs. apply H1.
        compute. omega.
    + SCase "bad".
      rewrite E1 in H1. inversion H1.
Qed.

Lemma indexr_max : forall X vs n (T: X),
                       indexr n vs = Some T ->
                       n < length vs.
Proof.
  intros X vs. induction vs.
  - Case "nil". intros. inversion H.
  - Case "cons".
    intros. inversion H. destruct a.
    case_eq (beq_nat n (length vs)); intros E2.
    + SSCase "hit".
      eapply beq_nat_true in E2. subst n. compute. eauto.
    + SSCase "miss".
      rewrite E2 in H1.
      assert (n < length vs). eapply IHvs. apply H1.
      compute. eauto.
Qed.

Lemma le_xx : forall a b,
                       a <= b ->
                       exists E, le_lt_dec a b = left E.
Proof. intros.
  case_eq (le_lt_dec a b). intros. eauto.
  intros. omega.
Qed.
Lemma le_yy : forall a b,
                       a > b ->
                       exists E, le_lt_dec a b = right E.
Proof. intros.
  case_eq (le_lt_dec a b). intros. omega.
  intros. eauto.
Qed.

Lemma index_extend : forall X vs n n' x (T: X),
                       index n vs = Some T ->
                       fresh vs <= n' ->
                       index n ((n',x)::vs) = Some T.

Proof.
  intros.
  assert (n < fresh vs). eapply index_max. eauto.
  assert (n <> n'). omega.
  assert (beq_nat n n' = false) as E. eapply beq_nat_false_iff; eauto.
  assert (fresh vs <= n') as E2. omega.
  elim (le_xx (fresh vs) n' E2). intros ? EX.
  unfold index. unfold index in H. rewrite H. rewrite E. rewrite EX. reflexivity.
Qed.

Lemma indexr_extend : forall X vs n n' x (T: X),
                       indexr n vs = Some T ->
                       indexr n ((n',x)::vs) = Some T.

Proof.
  intros.
  assert (n < length vs). eapply indexr_max. eauto.
  assert (beq_nat n (length vs) = false) as E. eapply beq_nat_false_iff. omega.
  unfold indexr. unfold indexr in H. rewrite H. rewrite E. reflexivity.
Qed.

(* splicing -- for stp_extend. not finished *)

Fixpoint splice n (T : ty) {struct T} : ty :=
  match T with
    | TTop         => TTop
    | TBot         => TBot
    | TBool        => TBool
    | TMem T1 T2   => TMem (splice n T1) (splice n T2)
    | TFun T1 T2   => TFun (splice n T1) (splice n T2)
    | TSelB i      => TSelB i
    | TSel i       => TSel i
    | TSelH i      => if le_lt_dec n i  then TSelH (i+1) else TSelH i
    | TAll T1 T2   => TAll (splice n T1) (splice n T2)
  end.

Definition splicett n (V: (id*ty)) :=
  match V with
    | (x,T) => (x,(splice n T))
  end.

Lemma splice_open_permute: forall (G0:tenv) T2 n j,
(open_rec j (TSelH (n + S (length G0))) (splice (length G0) T2)) =
(splice (length G0) (open_rec j (TSelH (n + length G0)) T2)).
Proof.
  intros G T. induction T; intros; simpl; eauto;
  try rewrite IHT1; try rewrite IHT2; try rewrite IHT; eauto.

  case_eq (le_lt_dec (length G) i); intros E LE; simpl; eauto.
  case_eq (beq_nat j i); intros E; simpl; eauto.
  case_eq (le_lt_dec (length G) (n + length G)); intros EL LE.
  assert (n + S (length G) = n + length G + 1). omega.
  rewrite H. eauto.
  omega.
Qed.

Lemma indexr_splice_hi: forall G0 G2 x0 x v1 T,
    indexr x0 (G2 ++ G0) = Some T ->
    length G0 <= x0 ->
    indexr (x0 + 1) (map (splicett (length G0)) (G2 ++ (x, v1) :: G0)) = Some (splice (length G0) T).
Proof.
  intros G0 G2. induction G2; intros.
  - eapply indexr_max in H. simpl in H. omega.
  - simpl in H. destruct a.
    case_eq (beq_nat x0 (length (G2 ++ G0))); intros E.
    + rewrite E in H. inversion H. subst. simpl.
      rewrite app_length in E.
      rewrite map_length. rewrite app_length. simpl.
      assert (beq_nat (x0 + 1) (length G2 + S (length G0)) = true). eapply beq_nat_true_iff. eapply beq_nat_true_iff in E. omega.
      rewrite H1. eauto.
    + rewrite E in H.  eapply IHG2 in H. eapply indexr_extend. eapply H. eauto.
Qed.

Lemma indexr_splice_lo0: forall G0 G2 x0 (T:ty),
    indexr x0 (G2 ++ G0) = Some T ->
    x0 < length G0 ->
    indexr x0 G0 = Some T.
Proof. admit. Qed.

Lemma indexr_splice_lo1: forall G0 x0 (T:ty) f,
    indexr x0 G0 = Some T ->
    map (splicett f) G0 = G0 ->
    indexr x0 G0 = Some (splice f T).
Proof. admit. Qed.

Lemma indexr_extend_mult: forall G0 G2 x0 (T:ty),
    indexr x0 G0 = Some T ->
    indexr x0 (G2++G0) = Some T.
Proof. admit. Qed.

Lemma indexr_splice_lo: forall G0 G2 x0 x v1 T f,
    indexr x0 (G2 ++ G0) = Some T ->
    map (splicett f) G0 = G0 ->
    x0 < length G0 ->
    indexr x0 (map (splicett f) (G2 ++ (x, v1) :: G0)) = Some (splice f T).
Proof.
  intros.
  assert (indexr x0 G0 = Some T). eapply indexr_splice_lo0; eauto.
  assert (indexr x0 (map (splicett f) G0) = Some (splice f T)).
  rewrite H0. eapply indexr_splice_lo1. eauto. eauto.
  rewrite map_app. simpl.
  eapply indexr_extend_mult. eapply indexr_extend. eauto.
Qed.

Lemma stp_splice : forall GX G0 G1 T1 T2 x v1,
   stp GX (G1++G0) T1 T2 ->
   map (splicett (length G0)) G0 = G0 ->
   stp GX (map (splicett (length G0)) (G1++(x,v1)::G0)) (splice (length G0) T1) (splice (length G0) T2).
Proof.
  intros GX G0 G1 T1 T2 x v1 H. remember (G1++G0) as G.
  revert G0 G1 HeqG.
  induction H; intros; subst GH; simpl; eauto.
  - admit.
  - admit.
  - Case "sela1".
    case_eq (le_lt_dec (length G0) x0); intros E LE.
    + eapply stp_sela1. eapply indexr_splice_hi with (T:=TMem TL TU). eauto. eauto.
      eapply IHstp. eauto. eauto.
    + eapply stp_sela1. eapply indexr_splice_lo with (T:=TMem TL TU). eauto. eauto. eauto.
      eapply IHstp. eauto. eauto.
  - Case "sela2". admit.
  - Case "selax".
    case_eq (le_lt_dec (length G0) x0); intros E LE.
    + eapply stp_selax. eapply indexr_splice_hi with (T:=TMem TL TU). eauto. eauto.
    + eapply stp_selax. eapply indexr_splice_lo with (T:=TMem TL TU). eauto. eauto. eauto.
  - Case "all".
    eapply stp_all.
    eapply IHstp1. eauto. eauto. eauto.

    admit. (* closed *)
    admit. (* closed *)

    specialize IHstp2 with (G3:=G0) (G4:=(0, T3) :: G2).
    simpl in IHstp2. rewrite map_length. rewrite app_length. simpl.
    repeat rewrite splice_open_permute with (j:=0). subst x0.
    rewrite app_length in IHstp2. simpl in IHstp2.
    eapply IHstp2. eauto. eauto.
Qed.

Lemma stp_extend : forall G1 GH T1 T2 x v1,
                       stp G1 GH T1 T2 ->
                       stp G1 ((x,v1)::GH) T1 T2.
Proof.
  (* use stp_splice: we need to have that env and types are well-formed *)
  admit.
Qed.

Lemma stp2_extend2 : forall x v1 G1 G2 T1 T2 H,
                       stp2 G1 T1 G2 T2 H ->
                       fresh G2 <= x ->
                       stp2 G1 T1 ((x,v1)::G2) T2 H.
Proof. admit. Qed.

Lemma stp2_extend1 : forall x v1 G1 G2 T1 T2 H,
                       stp2 G1 T1 G2 T2 H ->
                       fresh G1 <= x ->
                       stp2 ((x,v1)::G1) T1 G2 T2 H.
Proof. admit. Qed.

Lemma stp2_extendH : forall x v1 G1 G2 T1 T2 H,
                       stp2 G1 T1 G2 T2 H ->
                       stp2 G1 T1 G2 T2 ((x,v1)::H).
Proof. admit. Qed.

Lemma stp2_extendH_mult : forall G1 G2 T1 T2 H H2,
                       stp2 G1 T1 G2 T2 H ->
                       stp2 G1 T1 G2 T2 (H2++H).
Proof. admit. Qed.

Lemma stp2_extendH_mult0 : forall G1 G2 T1 T2 H2,
                       stp2 G1 T1 G2 T2 [] ->
                       stp2 G1 T1 G2 T2 H2.
Proof. admit. Qed.

Lemma stp2_reg2 : forall G1 G2 T1 T2 H ,
                       stp2 G1 T1 G2 T2 H ->
                       stp2 G2 T2 G2 T2 H.
Proof. admit. Qed.

Lemma stp2_reg1 : forall G1 G2 T1 T2 H,
                       stp2 G1 T1 G2 T2 H ->
                       stp2 G1 T1 G1 T1 H.
Proof. admit. Qed.

Lemma stp2_closed2 : forall G1 G2 T1 T2 H ,
                       stp2 G1 T1 G2 T2 H ->
                       closed 0 (length H) T2.
Proof. admit. Qed.

Lemma stp2_closed1 : forall G1 G2 T1 T2 H,
                       stp2 G1 T1 G2 T2 H ->
                       closed 0 (length H) T1.
Proof. admit. Qed.

Lemma valtp_extend : forall vs v x v1 T,
                       val_type vs v T ->
                       fresh vs <= x ->
                       val_type ((x,v1)::vs) v T.
Proof.
  intros. induction H; eauto; econstructor; eauto; eapply stp2_extend2; eauto.
Qed.

Lemma index_safe_ex: forall H1 G1 TF i,
             wf_env H1 G1 ->
             index i G1 = Some TF ->
             exists v, index i H1 = Some v /\ val_type H1 v TF.
Proof. intros. induction H.
   - Case "nil". inversion H0.
   - Case "cons". inversion H0.
     case_eq (le_lt_dec (fresh ts) n); intros ? E1.
     + SCase "ok".
       rewrite E1 in H3.
       assert ((fresh ts) <= n) as QF. eauto. rewrite <-(wf_fresh vs ts H1) in QF.
       elim (le_xx (fresh vs) n QF). intros ? EX.

       case_eq (beq_nat i n); intros E2.
       * SSCase "hit".
         assert (index i ((n, v) :: vs) = Some v). eauto. unfold index. rewrite EX. rewrite E2. eauto.
         assert (t = TF).
         unfold index in H0. rewrite E1 in H0. rewrite E2 in H0. inversion H0. eauto.
         subst t. eauto.
       * SSCase "miss".
         rewrite E2 in H3.
         assert (exists v0, index i vs = Some v0 /\ val_type vs v0 TF) as HI. eapply IHwf_env. eauto.
         inversion HI as [v0 HI1]. inversion HI1.
         eexists. econstructor. eapply index_extend; eauto. eapply valtp_extend; eauto.
     + SSCase "bad".
       rewrite E1 in H3. inversion H3.
Qed.

Lemma index_safeh_ex: forall H1 H2 G1 GH TF i,
             wf_env H1 G1 -> wf_envh H1 H2 GH ->
             indexr i GH = Some TF ->
             exists v, indexr i H2 = Some v /\ valh_type H1 H2 v TF.
Proof. intros. induction H0.
   - Case "nil". inversion H3.
   - Case "cons". inversion H3.
     case_eq (beq_nat i (length ts)); intros E2.
     * SSCase "hit".
       rewrite E2 in H2. inversion H2. subst. clear H2.
       assert (length ts = length vs). symmetry. eapply wfh_length. eauto.
       simpl. rewrite H1 in E2. rewrite E2.
       eexists. split. eauto. econstructor.
     * SSCase "miss".
       rewrite E2 in H2.
       assert (exists v : venv * ty,
                 indexr i vs = Some v /\ valh_type vvs vs v TF). eauto.
       destruct H1. destruct H1.
       eexists. split. eapply indexr_extend. eauto.
       inversion H4. subst.
       eapply v_tya. (* aenv is not constrained -- bit of a cheat?*)
Qed.

Inductive res_type: venv -> option vl -> ty -> Prop :=
| not_stuck: forall venv v T,
      val_type venv v T ->
      res_type venv (Some v) T.

Hint Constructors res_type.
Hint Resolve not_stuck.

Hint Constructors stp2.

Lemma stp2_trans: forall G1 G2 G3 T1 T2 T3 H,
  stp2 G1 T1 G2 T2 H ->
  stp2 G2 T2 G3 T3 H ->
  stp2 G1 T1 G3 T3 H.
Proof. admit. Qed.

(* used in trans -- need to generalize interface for induction *)
(*
Lemma stp2_narrow: forall x G1 G2 G3 G4 T1 T2 T3 T4 H,
  stp2 G1 T1 G2 T2 H -> (* careful about H! *)
  stp2 G3 T3 G4 T4 ((x,vtya G2 T2)::H) ->
  stp2 G3 T3 G4 T4 ((x,vtya G1 T1)::H).
Proof. admit. Qed.
 *)

Lemma index_miss {X}: forall x x1 (B:X) A G,
  index x ((x1,B)::G) = A ->
  fresh G <= x1 ->
  x <> x1 ->
  index x G = A.
Proof.
  intros.
  unfold index in H.
  elim (le_xx (fresh G) x1 H0). intros.
  rewrite H2 in H.
  assert (beq_nat x x1 = false). eapply beq_nat_false_iff. eauto.
  rewrite H3 in H. eapply H.
Qed.

Lemma index_hit {X}: forall x x1 (B:X) A G,
  index x ((x1,B)::G) = Some A ->
  fresh G <= x1 ->
  x = x1 ->
  B = A.
Proof.
  intros.
  unfold index in H.
  elim (le_xx (fresh G) x1 H0). intros.
  rewrite H2 in H.
  assert (beq_nat x x1 = true). eapply beq_nat_true_iff. eauto.
  rewrite H3 in H. inversion H. eauto.
Qed.

Lemma index_hit2 {X}: forall x x1 (B:X) A G,
  fresh G <= x1 ->
  x = x1 ->
  B = A ->
  index x ((x1,B)::G) = Some A.
Proof.
  intros.
  unfold index.
  elim (le_xx (fresh G) x1 H). intros.
  rewrite H2.
  assert (beq_nat x x1 = true). eapply beq_nat_true_iff. eauto.
  rewrite H3. rewrite H1. eauto.
Qed.

Lemma indexr_miss {X}: forall x x1 (B:X) A G,
  indexr x ((x1,B)::G) = A ->
  x <> (length G)  ->
  indexr x G = A.
Proof.
  intros.
  unfold indexr in H.
  assert (beq_nat x (length G) = false). eapply beq_nat_false_iff. eauto.
  rewrite H1 in H. eauto.
Qed.

Lemma indexr_hit {X}: forall x x1 (B:X) A G,
  indexr x ((x1,B)::G) = Some A ->
  x = length G ->
  B = A.
Proof.
  intros.
  unfold indexr in H.
  assert (beq_nat x (length G) = true). eapply beq_nat_true_iff. eauto.
  rewrite H1 in H. inversion H. eauto.
Qed.

Lemma indexr_hit0: forall GH (GX0:venv) (TX0:ty),
      indexr 0 (GH ++ [(0,(GX0, TX0))]) =
      Some (GX0, TX0).
Proof.
  intros GH. induction GH.
  - intros. simpl. eauto.
  - intros. simpl. destruct a. simpl. rewrite app_length. simpl.
    assert (length GH + 1 = S (length GH)). omega. rewrite H.
    eauto.
Qed.

Hint Resolve beq_nat_true_iff.
Hint Resolve beq_nat_false_iff.

Lemma closed_no_open: forall T x l j,
  closed_rec j l T ->
  T = open_rec j x T.
Proof.
  intros. induction H; intros; eauto;
  try solve [compute; compute in IHclosed_rec; rewrite <-IHclosed_rec; auto];
  try solve [compute; compute in IHclosed_rec1; compute in IHclosed_rec2; rewrite <-IHclosed_rec1; rewrite <-IHclosed_rec2; auto].

  Case "TSelB".
    unfold open_rec. assert (k <> i). omega.
    apply beq_nat_false_iff in H0.
    rewrite H0. auto.
Qed.

Lemma closed_upgrade: forall i j l T,
 closed_rec i l T ->
 j >= i ->
 closed_rec j l T.
Proof.
 intros. generalize dependent j. induction H; intros; eauto.
 Case "TBind". econstructor. eapply IHclosed_rec1. omega. eapply IHclosed_rec2. omega.
 Case "TSelB". econstructor. omega.
Qed.

Lemma closed_upgrade_free: forall i l k T,
 closed_rec i l T ->
 k >= l ->
 closed_rec i k T.
Proof.
 intros. generalize dependent k. induction H; intros; eauto.
 Case "TSelH". econstructor. omega.
Qed.

Lemma open_subst_commute: forall T2 TX (n:nat) x j,
closed j n TX ->
(open_rec j (TSelH x) (subst TX T2)) =
(subst TX (open_rec j (TSelH (x+1)) T2)).
Proof.
  intros T2 TX n. induction T2; intros; eauto.
  -  simpl. rewrite IHT2_1. rewrite IHT2_2. eauto. eauto. eauto.
  -  simpl. rewrite IHT2_1. rewrite IHT2_2. eauto. eauto. eauto.
  -  simpl. case_eq (beq_nat i 0); intros E. symmetry. eapply closed_no_open. eauto. simpl. eauto.
  - simpl. case_eq (beq_nat j i); intros E. simpl.
    assert (x+1<>0). omega. eapply beq_nat_false_iff in H0.
    assert (x=x+1-1). unfold id. omega.
    rewrite H0. eauto.
    simpl. eauto.
  -  simpl. rewrite IHT2_1. rewrite IHT2_2. eauto. eapply closed_upgrade. eauto. eauto. eauto.
Qed.

Lemma closed_no_subst: forall T j TX,
   closed_rec j 0 T ->
   subst TX T = T.
Proof.
  intros T. induction T; intros; inversion H; simpl; eauto;
            try rewrite (IHT j TX); eauto; try rewrite (IHT2 (S j) TX); eauto; try rewrite (IHT1 j TX); eauto; try rewrite (IHT2 j TX); eauto.

  eapply closed_upgrade. eauto. eauto.
    eapply closed_upgrade. eauto. eauto.

  subst. omega.
Qed.

Lemma closed_open: forall j n TX T, closed (j+1) n T -> closed j n TX -> closed j n (open_rec j TX T).
Proof.
  intros. generalize dependent j. induction T; intros; inversion H; unfold closed; try econstructor; try eapply IHT1; eauto; try eapply IHT2; eauto; try eapply IHT; eauto. eapply closed_upgrade. eauto. eauto.

  - Case "TSelB". simpl.
    case_eq (beq_nat j i); intros E. eauto.

    econstructor. eapply beq_nat_false_iff in E. omega.

  - eauto.
  - eapply closed_upgrade; eauto.
Qed.

Lemma closed_subst: forall j n TX T, closed j (n+1) T -> closed 0 n TX -> closed j (n) (subst TX T).
Proof.
  intros. generalize dependent j. induction T; intros; inversion H; unfold closed; try econstructor; try eapply IHT1; eauto; try eapply IHT2; eauto; try eapply IHT; eauto.

  - Case "TSelH". simpl.
    case_eq (beq_nat i 0); intros E. eapply closed_upgrade. eapply closed_upgrade_free. eauto. omega. eauto. omega.
    econstructor. assert (i > 0). eapply beq_nat_false_iff in E. omega. omega.
Qed.

Lemma subst_open_commute_m: forall j n m TX T2, closed (j+1) (n+1) T2 -> closed 0 m TX ->
    subst TX (open_rec j (TSelH (n+1)) T2) = open_rec j (TSelH n) (subst TX T2).
Proof.
  intros. generalize dependent j. generalize dependent n.
  induction T2; intros; inversion H; simpl; eauto;
          try rewrite IHT2_1; try rewrite IHT2_2; try rewrite IHT2; eauto.

  - Case "TSelH". simpl. case_eq (beq_nat i 0); intros E.
    eapply closed_no_open. eapply closed_upgrade. eauto. omega.
    eauto.
  - Case "TSelB". simpl. case_eq (beq_nat j i); intros E.
    simpl. case_eq (beq_nat (n+1) 0); intros E2. eapply beq_nat_true_iff in E2. omega.
    assert (n+1-1 = n). omega. eauto.
    eauto.
Qed.

Lemma subst_open_commute: forall j n TX T2, closed (j+1) (n+1) T2 -> closed 0 0 TX ->
    subst TX (open_rec j (TSelH (n+1)) T2) = open_rec j (TSelH n) (subst TX T2).
Proof.
  intros. eapply subst_open_commute_m; eauto.
Qed.

Lemma subst_open_zero: forall j k TX T2, closed k 0 T2 ->
    subst TX (open_rec j (TSelH 0) T2) = open_rec j TX T2.
Proof.
  intros. generalize dependent k. generalize dependent j. induction T2; intros; inversion H; simpl; eauto; try rewrite (IHT2_1 _ k); try rewrite (IHT2_2 _ (S k)); try rewrite (IHT2_2 _ (S k)); try rewrite (IHT2 _ k); eauto.

  eapply closed_upgrade; eauto.
  eapply closed_upgrade; eauto.

  case_eq (beq_nat i 0); intros E. omega. omega.

  case_eq (beq_nat j i); intros E. eauto. eauto.
Qed.

Lemma Forall2_length: forall A B f (G1:list A) (G2:list B),
                        Forall2 f G1 G2 -> length G1 = length G2.
Proof.
  intros. induction H.
  eauto.
  simpl. eauto.
Qed.

Lemma nosubst_intro: forall j T, closed j 0 T -> nosubst T.
Proof.
  intros. generalize dependent j. induction T; intros; inversion H; simpl; eauto.
  omega.
Qed.

Lemma nosubst_open: forall j TX T2, nosubst TX -> nosubst T2 -> nosubst (open_rec j TX T2).
Proof.
  intros. generalize dependent j. induction T2; intros; try inversion H0; simpl; eauto.

  case_eq (beq_nat j i); intros E. eauto. eauto.
Qed.

(* substitution for one-env stp. not necessary, but good sanity check *)

Definition substt (UX: ty) (V: (id*ty)) :=
  match V with
    | (x,T) => (x-1,(subst UX T))
  end.

Lemma indexr_subst: forall GH0 x TX TL TU,
   indexr x (GH0 ++ [(0, TMem TBot TX)]) = Some (TMem TL TU) ->
   x = 0 /\ TX = TU \/
   x > 0 /\ indexr (x-1) (map (substt TX) GH0) = Some (TMem (subst TX TL) (subst TX TU)).
Proof.
  intros GH0. induction GH0; intros.
  - simpl in H. case_eq (beq_nat x 0); intros E.
    + rewrite E in H. inversion H.
      left. split. eapply beq_nat_true_iff. eauto. eauto.
    + rewrite E in H. inversion H.
  -  destruct a. unfold id in H. remember ((length (GH0 ++ [(0, TMem TBot TX)]))) as L.
     case_eq (beq_nat x L); intros E.
     + assert (x = L). eapply beq_nat_true_iff. eauto.
       eapply indexr_hit in H.
       right. split. rewrite app_length in HeqL. simpl in HeqL. omega.
       assert ((x - 1) = (length (map (substt TX) GH0))).
       rewrite map_length. rewrite app_length in HeqL. simpl in HeqL. unfold id. omega.
       simpl.
       eapply beq_nat_true_iff in H1. unfold id in H1. unfold id. rewrite H1. subst. eauto. eauto. subst. eauto.
     + assert (x <> L). eapply beq_nat_false_iff. eauto.
       eapply indexr_miss in H. eapply IHGH0 in H.
       inversion H. left. eapply H1.
       right. inversion H1. split. eauto.
       simpl.
       assert ((x - 1) <> (length (map (substt TX) GH0))).
       rewrite app_length in HeqL. simpl in HeqL. rewrite map_length.
       unfold not. intros. subst L. unfold id in H0. unfold id in H2. unfold not in H0. eapply H0. unfold id in H4. rewrite <-H4. omega.
       eapply beq_nat_false_iff in H4. unfold id in H4. unfold id. rewrite H4.
       eauto. subst. eauto.
Qed.

Lemma stp_substitute: forall T1 T2 GX GH,
   stp GX GH T1 T2 ->
   forall GH0 TX,
     GH = (GH0 ++ [(0,TMem TBot TX)]) ->
     closed 0 0 TX ->
     stp GX (map (substt TX) GH0) TX TX ->
     stp GX (map (substt TX) GH0)
         (subst TX T1)
         (subst TX T2).
Proof.
  intros T1 T2 GX GH H.
  induction H.
  - Case "top". eauto.
  - Case "bot". eauto.
  - Case "bool". eauto.
  - Case "fun". intros. simpl. eapply stp_fun. eauto. eauto.
  - Case "mem". intros. simpl. eapply stp_mem. eauto. eauto.
  - Case "sel1". admit.
  - Case "sel2". admit.
  - Case "selx". admit.
  - Case "sela1". intros GH0 TX ? ? ?. simpl.
    subst GH. specialize (indexr_subst _ x TX TL TU H). intros.
    destruct H1; destruct H1.
    + subst. simpl.
      specialize (IHstp GH0 TU).
      assert (subst TU TU = TU). eapply closed_no_subst; eauto.
      rewrite H1 in IHstp.
      eapply IHstp. eauto. eauto. eauto.
    + subst. simpl.
      assert (beq_nat x 0 = false). eapply beq_nat_false_iff; omega. rewrite H5. simpl.
      eapply stp_sela1. eapply H4. eapply IHstp. eauto. eauto. eauto.
  - Case "sela2". admit.
  - Case "selax". intros GH0 TX ? ? ?. simpl.
    subst GH. specialize (indexr_subst _ x TX TL TU H). intros.
    destruct H0; destruct H0.
    + subst. simpl. eauto.
    + subst. simpl. assert (beq_nat x 0 = false). eapply beq_nat_false_iff. omega. rewrite H4. eapply stp_selax. eauto.
  - Case "all".
    intros GH0 TX ? ? ?.
    simpl. eapply stp_all.
    + eapply IHstp1; eauto.
    + rewrite map_length. eauto.
    + rewrite map_length. eapply closed_subst. subst GH.
      rewrite app_length in H1. simpl in H1. eauto.
      eapply closed_upgrade_free; eauto. omega.
    + rewrite map_length. eapply closed_subst. subst GH.
      rewrite app_length in H2. simpl in H2. eauto.
      eapply closed_upgrade_free; eauto. omega.
    + specialize IHstp2 with (GH0:=(0, T3)::GH0) (TX:=TX).
      subst GH. simpl in IHstp2.
      unfold open. unfold open in IHstp2.
      subst x.
      rewrite open_subst_commute with (n:=0).
      rewrite open_subst_commute with (n:=0).
      rewrite app_length in IHstp2. simpl in IHstp2.
      eapply IHstp2; eauto. eapply stp_extend; eauto.
      eauto. eauto.
Qed.

(*
when and how we can replace with multiple environments:

stp2 G1 T1 G2 T2 (GH0 ++ [(0,vtya GX TX)])

1) T1 closed

   stp2 G1 T1 G2' T2' (subst GH0)

2) G1 contains (GX TX) at some index x1

   index x1 G1 = (GX TX)
   stp2 G (subst (TSel x1) T1) G2' T2'

3) G1 = GX <----- valid for Fsub, but not for DOT !

   stp2 G1 (subst TX T1) G2' T2'

4) G1 and GX unrelated

   stp2 ((GX,TX) :: G1) (subst (TSel (length G1)) T1) G2' T2'

*)

(* ---- two-env substitution. first define what 'compatible' types mean. ---- *)

Definition compat (GX:venv) (TX: ty) (G1:venv) (T1:ty) (T1':ty) :=
  (exists x1 TX0, index x1 G1 = Some (vty GX TX0) /\ T1' = (subst (TSel x1) T1) /\ TX = (TMem TX0 TX0)) \/
(*  (G1 = GX /\ T1' = (subst TX T1)) \/ *)   (* this is doesn't work for DOT *)
  (closed_rec 0 0 T1 /\ T1' = T1) \/ (* this one is for convenience: redundant with next *)
  (nosubst T1 /\ T1' = subst TTop T1).

Definition compat2 (GX:venv) (TX: ty) (p1:id*(venv*ty)) (p2:id*(venv*ty)) :=
  match p1, p2 with
      (n1,(G1,T1)), (n2,(G2,T2)) => n1=n2(*+1 disregarded*) /\ G1 = G2 /\ compat GX TX G1 T1 T2
  end.

Lemma indexr_compat_miss0: forall GH GH' GX TX (GXX:venv) (TXX:ty) n,
      Forall2 (compat2 GX TX) GH GH' ->
      indexr (n+1) (GH ++ [(0,(GX, TX))]) = Some (GXX,TXX) ->
      exists TXX', indexr n GH' = Some (GXX,TXX') /\ compat GX TX GXX TXX TXX'.
Proof.
  intros. revert n H0. induction H.
  - intros. simpl. eauto. simpl in H0. assert (n+1 <> 0). omega. eapply beq_nat_false_iff in H. rewrite H in H0. inversion H0.
  - intros. simpl. destruct y.
    case_eq (beq_nat n (length l')); intros E.
    + simpl in H1. destruct x. rewrite app_length in H1. simpl in H1.
      assert (n = length l'). eapply beq_nat_true_iff. eauto.
      assert (beq_nat (n+1) (length l + 1) = true). eapply beq_nat_true_iff.
      rewrite (Forall2_length _ _ _ _ _ H0). omega.
      rewrite H3 in H1. destruct p. destruct p0. inversion H1. subst. simpl in H.
      destruct H. destruct H2. subst. inversion H1. subst.
      eexists. eauto.
    + simpl in H1. destruct x.
      assert (n <> length l'). eapply beq_nat_false_iff. eauto.
      assert (beq_nat (n+1) (length l + 1) = false). eapply beq_nat_false_iff.
      rewrite (Forall2_length _ _ _ _ _ H0). omega.
      rewrite app_length in H1. simpl in H1.
      rewrite H3 in H1.
      eapply IHForall2. eapply H1.
Qed.

Ltac eu := repeat match goal with
                    | H: exists _, _ |- _ => destruct H
                    | H: _ /\  _ |- _ => destruct H
           end.

Lemma compat_top: forall GX TX G1 T1',
  compat GX TX G1 TTop T1' -> closed 0 0 TX -> T1' = TTop.
Proof.
  intros ? ? ? ? CC CLX. repeat destruct CC as [|CC]; eu; eauto.
Qed.

Lemma compat_bot: forall GX TX G1 T1',
  compat GX TX G1 TBot T1' -> closed 0 0 TX -> T1' = TBot.
Proof.
  intros ? ? ? ? CC CLX. repeat destruct CC as [|CC]; eu; eauto.
Qed.

Lemma compat_bool: forall GX TX G1 T1',
  compat GX TX G1 TBool T1' -> closed 0 0 TX -> T1' = TBool.
Proof.
  intros ? ? ? ? CC CLX. repeat destruct CC as [|CC]; eu; eauto.
Qed.

Lemma compat_mem: forall GX TX G1 T1 T2 T1',
    compat GX TX G1 (TMem T1 T2) T1' ->
    closed 0 0 TX ->
    exists TA TB, T1' = TMem TA TB /\
                  compat GX TX G1 T1 TA /\
                  compat GX TX G1 T2 TB.
Proof.
  intros ? ? ? ? ? ? CC CLX. repeat destruct CC as [|CC].
  - eu. repeat eexists; eauto. + left. repeat eexists; eauto. + left. repeat eexists; eauto.
  - eu. repeat eexists; eauto. + right. left. inversion H. eauto. + right. left. inversion H. eauto.
  - eu. repeat eexists; eauto. + right. right. inversion H. eauto. + right. right. inversion H. eauto.
Qed.

Lemma compat_fun: forall GX TX G1 T1 T2 T1',
    compat GX TX G1 (TFun T1 T2) T1' ->
    closed_rec 0 0 TX ->
    exists TA TB, T1' = TFun TA TB /\
                  compat GX TX G1 T1 TA /\
                  compat GX TX G1 T2 TB.
Proof.
  intros ? ? ? ? ? ? CC CLX. repeat destruct CC as [|CC].
  - eu. repeat eexists; eauto. + left. repeat eexists; eauto. + left. repeat eexists; eauto.
  - eu. repeat eexists; eauto. + right. left. inversion H. eauto. + right. left. inversion H. eauto.
  - eu. repeat eexists; eauto. + right. right. inversion H. eauto. + right. right. inversion H. eauto.
Qed.

Lemma compat_sel: forall GX TX G1 T1' (GXX:venv) (TXX:ty) x,
    compat GX TX G1 (TSel x) T1' ->
    closed 0 0 TX ->
    closed 0 0 TXX ->
    index x G1 = Some (vty GXX TXX) ->
    exists TXX', T1' = (TSel x) /\ compat GX TX GXX TXX TXX'
.
Proof.
  intros ? ? ? ? ? ? ? CC CL CL1 IX. repeat destruct CC as [|CC].
  - eu. repeat eexists; eauto. + right. left. simpl in H0. eauto.
  - eu. repeat eexists; eauto. + right. left. simpl in H0. eauto.
  - eu. repeat eexists; eauto. + right. left. simpl in H0. eauto.
Qed.

Lemma compat_selh: forall GX TX G1 T1' GH0 GH0' (GXX:venv) (TXX:ty) x,
    compat GX TX G1 (TSelH x) T1' ->
    closed 0 0 TX ->
    indexr x (GH0 ++ [(0, (GX, TX))]) = Some (GXX, TXX) ->
    Forall2 (compat2 GX TX) GH0 GH0' ->
    (x = 0 /\ GXX = GX /\ TXX = TX) \/
    exists TXX',
      x > 0 /\ T1' = TSelH (x-1) /\
      indexr (x-1) GH0' = Some (GXX, TXX') /\
      compat GX TX GXX TXX TXX'
.
Proof.
  intros ? ? ? ? ? ? ? ? ? CC CL IX FA.
  unfold id in x.
  case_eq (beq_nat x 0); intros E.
  - left. assert (x = 0). eapply beq_nat_true_iff. eauto. subst x. rewrite indexr_hit0 in IX. inversion IX. eauto.
  - right. assert (x <> 0). eapply beq_nat_false_iff. eauto.
    assert (x > 0). omega. remember (x-1) as y. assert (x = y+1) as Y. omega. subst x.
    eapply (indexr_compat_miss0 GH0 GH0' _ _ _ _ _ FA) in IX.
    repeat destruct CC as [|CC].
    + eu. simpl in H4. rewrite E in H4. rewrite <-Heqy in H4. eexists. eauto.
    + eu. inversion H1. omega.
    + eu. simpl in H4. rewrite E in H4. rewrite <-Heqy in H4. eexists. eauto.
Qed.

Lemma compat_all: forall GX TX G1 T1 T2 T1' n,
    compat GX TX G1 (TAll T1 T2) T1' ->
    closed 0 0 TX ->
    closed 1 (n+1) T2 ->
    exists TA TB, T1' = TAll TA TB /\
                  closed 1 n TB /\
                  compat GX TX G1 T1 TA /\
                  compat GX TX G1 (open_rec 0 (TSelH (n+1)) T2) (open_rec 0 (TSelH n) TB).
Proof.
  intros ? ? ? ? ? ? ? CC CLX CL2. repeat destruct CC as [|CC].

  - eu. simpl in H0. repeat eexists; eauto. eapply closed_subst; eauto.
    + unfold compat. left. eexists; eauto.
    + unfold compat. left. repeat eexists; eauto. rewrite subst_open_commute; eauto.

  - eu. simpl in H0. inversion H. repeat eexists; eauto. eapply closed_upgrade_free; eauto. omega.
    + unfold compat. right. right. split. eapply nosubst_intro; eauto. symmetry. eapply closed_no_subst; eauto.
    + unfold compat. right. right. split.
      * eapply nosubst_open. simpl. omega. eapply nosubst_intro. eauto.
      * rewrite subst_open_commute.  assert (T2 = subst TTop T2) as E. symmetry. eapply closed_no_subst; eauto. rewrite <-E. eauto. eauto. eauto.

  - eu. simpl in H0. destruct H. repeat eexists; eauto. eapply closed_subst; eauto. eauto.
    + unfold compat. right. right. eauto.
    + unfold compat. right. right. split.
      * eapply nosubst_open. simpl. omega. eauto.
      * rewrite subst_open_commute; eauto.
Qed.

Lemma stp2_substitute: forall G1 G2 T1 T2 GH,
   stp2 G1 T1 G2 T2 GH ->
   forall GH0 GH0' GX TX T1' T2',
     GH = (GH0 ++ [(0,(GX, TX))]) ->
     stp2 GX TX GX TX GH0' ->
     closed 0 0 TX ->
     compat GX TX G1 T1 T1' ->
     compat GX TX G2 T2 T2' ->
     Forall2 (compat2 GX TX) GH0 GH0' ->
     stp2 G1 T1' G2 T2' GH0'.
Proof.
  intros G1 G2 T1 T2 GH H.
  induction H.
  - Case "top".
    intros GH0 GH0' GXX TXX T1' T2' ? RF CX IX1 IX2 FA.
    eapply compat_top in IX2.
    subst. eauto. eauto.

  - Case "bot".
    intros GH0 GH0' GXX TXX T1' T2' ? RF CX IX1 IX2 FA.
    eapply compat_bot in IX1.
    subst. eauto. eauto.

  - Case "bool".
    intros GH0 GH0' GXX TXX T1' T2' ? RF CX IX1 IX2 FA.
    eapply compat_bool in IX1.
    eapply compat_bool in IX2.
    subst. eauto. eauto. eauto.

  - Case "fun".
    intros GH0 GH0' GXX TXX T1' T2' ? RF CX IX1 IX2 FA.
    eapply compat_fun in IX1. repeat destruct IX1 as [? IX1].
    eapply compat_fun in IX2. repeat destruct IX2 as [? IX2].
    subst. eauto. eauto. eauto.

  - Case "mem".
    intros GH0 GH0' GXX TXX T1' T2' ? RF CX IX1 IX2 FA.
    eapply compat_mem in IX1. repeat destruct IX1 as [? IX1].
    eapply compat_mem in IX2. repeat destruct IX2 as [? IX2].
    subst. eauto. eauto. eauto.

  - Case "sel1".
    intros GH0 GH0' GXX TXX T1' T2' ? RF CX IX1 IX2 FA.

    assert (length GH = length GH0 + 1). subst GH. eapply app_length.
    assert (length GH0 = length GH0') as EL. eapply Forall2_length. eauto.

    eapply (compat_sel GXX TXX G1 T1' GX TX) in IX1. repeat destruct IX1 as [? IX1].

    assert (compat GXX TXX GX TX TX) as CPX. right. left. eauto.

    subst.
    eapply stp2_sel1. eauto. eauto.
    eapply IHstp2. eauto. eauto. eauto. eauto. eauto. eauto.
    eauto. eauto. eauto.

  - Case "sel2".
    intros GH0 GH0' GXX TXX T1' T2' ? RF CX IX1 IX2 FA.

    assert (length GH = length GH0 + 1). subst GH. eapply app_length.
    assert (length GH0 = length GH0') as EL. eapply Forall2_length. eauto.

    eapply (compat_sel GXX TXX G2 T2' GX TX) in IX2. repeat destruct IX2 as [? IX2].

    assert (compat GXX TXX GX TX TX) as CPX. right. left. eauto.

    subst.
    eapply stp2_sel2. eauto. eauto.
    eapply IHstp2. eauto. eauto. eauto. eauto. eauto. eauto.
    eauto. eauto. eauto.

  - Case "sela1".
    intros GH0 GH0' GXX TXX T1' T2' ? RF CX IX1 IX2 FA.

    assert (length GH = length GH0 + 1). subst GH. eapply app_length.
    assert (length GH0 = length GH0') as EL. eapply Forall2_length. eauto.

    assert (compat GXX TXX G1 (TSelH x) T1') as IXX. eauto.

    eapply (compat_selh GXX TXX G1 T1' GH0 GH0' GX (TMem TL TU)) in IX1. repeat destruct IX1 as [? IX1].

    destruct IX1.
    + SCase "x = 0".
      repeat destruct IXX as [|IXX]; eu.
      * subst. simpl. inversion H6. inversion CX. subst.
        eapply stp2_sel1. eauto. eauto.
        eapply IHstp2; eauto.
        right. left. eauto.
      * subst x. inversion H4. omega.
      * subst x. destruct H4. eauto.
    + SCase "x > 0".
      eu. subst.
      eapply compat_mem in H6. eu. subst.
      eapply stp2_sela1. eauto. eapply IHstp2; eauto. eauto.
    (* remaining obligations *)
    + eauto. + subst GH. eauto. + eauto.

  - Case "selax".

    intros GH0 GH0' GXX TXX T1' T2' ? RFL CX IX1 IX2 FA.

    assert (length GH = length GH0 + 1). subst GH. eapply app_length.
    assert (length GH0 = length GH0') as EL. eapply Forall2_length. eauto.

    assert (compat GXX TXX G1 (TSelH x) T1') as IXX1. eauto.
    assert (compat GXX TXX G2 (TSelH x) T2') as IXX2. eauto.

    eapply (compat_selh GXX TXX G1 T1' GH0 GH0' GX TX) in IX1. repeat destruct IX1 as [? IX1].
    eapply (compat_selh GXX TXX G2 T2' GH0 GH0' GX TX) in IX2. repeat destruct IX2 as [? IX2].

    destruct x; destruct IX1; eu; try omega; destruct IX2; eu; try omega; subst.
    + SCase "x = 0".
      assert (not (nosubst (TSelH 0))). admit.
      assert (not (closed 0 0 (TSelH 0))). admit.
      destruct IXX1 as [IXX1|IXX1]; destruct IXX1; eu; try contradiction.
      destruct IXX2 as [IXX2|IXX2]; destruct IXX2; eu; try contradiction.
      * SSCase "sel-sel".
        (* NOTE: we rely on inverting RFL = stp (TMem TX TX) (TMem TX TX) here!! *)
        (* since this is passed in externally we should be safe. *)
        (* otherwise we could take wf evidence and apply reflexivity *)
        subst. inversion CX. inversion H13. (* TMem = TMem *) inversion RFL. subst.
        simpl. eapply stp2_sel1. eauto. eauto. eapply stp2_sel2. eauto. eauto. eauto.
    + SCase "x > 0".
      destruct IXX1; destruct IXX2; eu; subst; eapply stp2_selax; eauto.
    (* leftovers *)
    + eauto. + subst. eauto. + eauto. + eauto. + subst. eauto. + eauto.

  - Case "all".
    intros GH0 GH0' GX TX T1' T2' ? RFL CX IX1 IX2 FA.

    assert (length GH = length GH0 + 1). subst GH. eapply app_length.
    assert (length GH0 = length GH0') as EL. eapply Forall2_length. eauto.

    eapply compat_all in IX1. repeat destruct IX1 as [? IX1].
    eapply compat_all in IX2. repeat destruct IX2 as [? IX2].

    subst.

    eapply stp2_all.
    + eapply IHstp2_1. eauto. eauto. eauto. eauto. eauto. eauto.
    + eauto.
    + eauto.
    + subst. specialize IHstp2_2 with (GH1 := (0, (G2, T3))::GH0).
      eapply IHstp2_2.
      reflexivity.
      eapply stp2_extendH. eauto. eauto.
      rewrite app_length. simpl. rewrite EL. eauto.
      rewrite app_length. simpl. rewrite EL. eauto.
      eapply Forall2_cons. simpl. eauto. eauto.
    + eauto.
    + eauto. subst GH. rewrite <-EL. eapply closed_upgrade_free. eauto. omega.
    + eauto.
    + eauto. subst GH. rewrite <-EL. eapply closed_upgrade_free. eauto. omega.
Qed.

(* not used right now, but could be a useful helper *)
Lemma stp2_concretize: forall G1 G2 T1X T2X TX,
   stp2 G1 (open (TSelH 0) T1X) G2 (open (TSelH 0) T2X) [(0,(G2, TX))] ->
   stp2 ((fresh G1, vty G2 TX)::G1) (open (TSel (fresh G1)) T1X)
     G2 (open TX T2X) [].
Proof.
  admit. (* call aux version above *)
Qed.

(* --------------------------------- *)

(*
Lemma stp_wf_subst: forall G1 GH T11 T12 x,
  stp G1 GH T11 T11 ->
  stp G1 ((x, TMem T11) :: GH) (open (TSelH x) T12) (open (TSelH x) T12) ->
  stp G1 GH (open T11 T12) (open T11 T12).
Proof.
  admit.
Qed.

Lemma has_type_wf: forall G1 t T,
  has_type G1 t T ->
  stp G1 [] T T.
Proof.
  intros. induction H.
  - Case "true". eauto.
  - Case "false". eauto.
  - Case "var". eauto.
  - Case "app".
    assert (stp env [] (TFun T1 T2) (TFun T1 T2)) as WF. eauto.
    inversion WF. eauto.
  - Case "abs".
    eauto.
  - Case "tapp".
    assert (stp env [] (TAll T11 T12) (TAll T11 T12)) as WF. eauto.
    inversion WF. subst. eapply stp_wf_subst; eauto.
  - Case "tabs".
    eauto.
Qed.
*)

(* TODO *)
Lemma stp_to_stp2: forall G1 GH T1 T2,
  stp G1 GH T1 T2 ->
  forall GX GY, wf_env GX G1 -> wf_envh GX GY GH ->
  stp2 GX T1 GX T2 GY.
Proof.
  intros G1 G2 T1 T2 ST. induction ST; intros GX GY WX WY.
  - Case "top". eauto.
  - Case "bot". eauto.
  - Case "bool". eauto.
  - Case "fun". eauto.
  - Case "mem". eauto.
  - Case "sel1".
    assert (exists v : vl, index x GX = Some v /\ val_type GX v (TMem TL TU)) as A.
    eapply index_safe_ex. eauto. eauto.
    destruct A as [? [? VT]].
    inversion VT; try solve by inversion; subst.
    eapply stp2_sel1; eauto. inversion H2. subst. eapply stp2_closed1 in H11. eauto.
    inversion H2. subst.
    eapply stp2_extendH_mult with (H2:=GY) in H11. rewrite app_nil_r in H11.
    eapply stp2_trans. eapply H11. eapply IHST; eauto.
  - Case "sel2". admit.
  - Case "selx". eauto.
    assert (exists v : vl, index x GX = Some v /\ val_type GX v (TMem TL TU)) as A.
    eapply index_safe_ex. eauto. eauto. eauto.
    destruct A as [? [? VT]].
    inversion VT; try solve by inversion; subst.
    inversion H2. subst.
    eapply stp2_sel2. eauto. eapply stp2_closed1 in H11. eauto.
    eapply stp2_sel1. eauto. eapply stp2_closed1 in H11. eauto.
    eapply stp2_extendH_mult with (H2:=GY) in H11. rewrite app_nil_r in H11.
    eapply stp2_reg1. eapply H11.
  - Case "sela1". eauto.
    assert (exists v, indexr x GY = Some v /\ valh_type GX GY v (TMem TL TU)) as A.
    eapply index_safeh_ex. eauto. eauto. eauto.
    destruct A as [? [? VT]]. destruct x0.
    inversion VT. subst.
    eapply stp2_sela1. eauto. eapply IHST. eauto. eauto.
  - Case "sela2". admit.
  - Case "selax". eauto.
    assert (exists v, indexr x GY = Some v /\ valh_type GX GY v (TMem TL TU)) as A.
    eapply index_safeh_ex. eauto. eauto. eauto.
    destruct A as [? [? VT]]. destruct x0.
    destruct VT. subst.
    eapply stp2_selax. eauto. eauto.
  - Case "all".
    subst x. assert (length GY = length GH). eapply wfh_length; eauto.
    eapply stp2_all. eauto. rewrite H. eauto. rewrite H.  eauto.
    rewrite H.
    eapply IHST2. eauto. eapply wfeh_cons. eauto.
Qed.

Lemma valtp_widen: forall vf H1 H2 T1 T2,
  val_type H1 vf T1 ->
  stp2 H1 T1 H2 T2 [] ->
  val_type H2 vf T2.
Proof.
  intros. inversion H; econstructor; eauto; eapply stp2_trans; eauto.
Qed.

Lemma restp_widen: forall vf H1 H2 T1 T2,
  res_type H1 vf T1 ->
  stp2 H1 T1 H2 T2 [] ->
  res_type H2 vf T2.
Proof.
  intros. inversion H. eapply not_stuck. eapply valtp_widen; eauto.
Qed.

Lemma invert_abs: forall venv vf T1 T2,
  val_type venv vf (TFun T1 T2) ->
  exists env tenv f x y T3 T4,
    vf = (vabs env f x y) /\
    fresh env <= f /\
    1 + f <= x /\
    wf_env env tenv /\
    has_type ((x,T3)::(f,TFun T3 T4)::tenv) y T4 /\
    stp2 venv T1 env T3 [] /\
    stp2 env T4 venv T2 [].
Proof.
  intros. inversion H; try solve by inversion. inversion H4. subst. repeat eexists; repeat eauto.
Qed.

Lemma invert_tabs: forall venv vf T1 T2,
  val_type venv vf (TAll (TMem T1 T1) T2) ->
  stp2 venv T2 venv T2 [] ->
  exists env tenv x y T3 T4,
    vf = (vtabs env x T3 y) /\
    fresh env = x /\
    wf_env env tenv /\
    has_type ((x,T3)::tenv) y (open (TSel x) T4) /\
    stp2 venv (TMem T1 T1) env T3 [] /\
    stp2 ((x,vty venv T1)::env) (open (TSel x) T4) venv T2 []. (* (open T1 T2) []. *)
Proof.
  intros. inversion H; try solve by inversion. inversion H4. subst. repeat eexists; repeat eauto.
  remember (fresh venv1) as x.
  remember (x + fresh venv0) as xx.

  (* inversion of TAll < TAll *)
  assert (stp2 venv0 (TMem T1 T1) venv1 T0 []). eauto.
  assert (stp2 venv1 (open (TSelH 0) T3) venv0 (open (TSelH 0) T2) [(0,(venv0, TMem T1 T1))]). {
    eauto.
  }

  (* need reflexivity *)
  assert (stp2 venv0 T1 venv0 T1 []). eapply stp2_reg1. eauto.
  assert (closed 0 0 T1). eapply stp2_closed1 in H6. simpl in H6. eauto.

  (* now rename *)

  assert (stp2 ((fresh venv1,vty venv0 T1) :: venv1) (open_rec 0 (TSel (fresh venv1)) T3) venv0 (T2) []). { (* was open T1 T2 *)
    assert (closed 0 (length ([]:aenv)) T2). eapply stp2_closed1; eauto.
    assert (open (TSelH 0) T2 = T2) as OP2. symmetry. eapply closed_no_open; eauto.
    eapply stp2_substitute with (GH0:=nil).
    eapply stp2_extend1. eapply H5. eauto.
    simpl. eauto.
    eauto.
    eauto.
    left. eexists. eexists. split. eapply index_hit2. eauto. eauto. eauto. unfold open. rewrite (subst_open_zero 0 1). subst x. eauto. eauto.
    right. left. split. rewrite OP2. eauto. eauto. eauto.
  }

  (* done *)
  subst. eauto.
Grab Existential Variables. apply nil.
Qed.

(* if not a timeout, then result not stuck and well-typed *)

Theorem full_safety : forall n e tenv venv res T,
  teval n venv e = Some res -> has_type tenv e T -> wf_env venv tenv ->
  res_type venv res T.

Proof.
  intros n. induction n.
  (* 0 *)   intros. inversion H.
  (* S n *) intros. destruct e; inversion H.

  - Case "True".
    remember (ttrue) as e. induction H0; inversion Heqe; subst.
    + eapply not_stuck. eapply v_bool; eauto.
    + eapply restp_widen. eapply IHhas_type; eauto. eapply stp_to_stp2; eauto. econstructor.

  - Case "False".
    remember (tfalse) as e. induction H0; inversion Heqe; subst.
    + eapply not_stuck. eapply v_bool; eauto.
    + eapply restp_widen. eapply IHhas_type; eauto. eapply stp_to_stp2; eauto. econstructor.

  - Case "Var".
    remember (tvar i) as e. induction H0; inversion Heqe; subst.
    + destruct (index_safe_ex venv0 env T1 i) as [v [I V]]; eauto.
      rewrite I. eapply not_stuck. eapply V.

    + eapply restp_widen. eapply IHhas_type; eauto. eapply stp_to_stp2; eauto. econstructor.

  - Case "App".
    remember (tapp e1 e2) as e. induction H0; inversion Heqe; subst.
    +
      remember (teval n venv0 e1) as tf.
      remember (teval n venv0 e2) as tx.

      destruct tx as [rx|]; try solve by inversion.
      assert (res_type venv0 rx T1) as HRX. SCase "HRX". subst. eapply IHn; eauto.
      inversion HRX as [? vx].

      destruct tf as [rf|]; subst rx; try solve by inversion.
      assert (res_type venv0 rf (TFun T1 T2)) as HRF. SCase "HRF". subst. eapply IHn; eauto.
      inversion HRF as [? vf].

      destruct (invert_abs venv0 vf T1 T2) as
          [env1 [tenv [f0 [x0 [y0 [T3 [T4 [EF [FRF [FRX [WF [HTY [STX STY]]]]]]]]]]]]]. eauto.
      (* now we know it's a closure, and we have has_type evidence *)

      assert (res_type ((x0,vx)::(f0,vf)::env1) res T4) as HRY.
        SCase "HRY".
          subst. eapply IHn. eauto. eauto.
          (* wf_env f x *) econstructor. eapply valtp_widen; eauto. eapply stp2_extend2. eapply stp2_extend2. eauto. eauto. eauto.
          (* wf_env f   *) econstructor. eapply v_abs; eauto. eapply stp2_extend2. eapply stp2_fun. eapply stp2_reg2. eauto. eapply stp2_reg1. eauto. eauto.
          eauto.

      inversion HRY as [? vy].

      eapply not_stuck. eapply valtp_widen; eauto. eapply stp2_extend1. eapply stp2_extend1. eauto. eauto. eauto.

    + eapply restp_widen. eapply IHhas_type; eauto. eapply stp_to_stp2; eauto. econstructor.

  - Case "Abs".
    remember (tabs i i0 e) as xe. induction H0; inversion Heqxe; subst.
    + eapply not_stuck. eapply v_abs; eauto. rewrite (wf_fresh venv0 env H1). eauto. eapply stp_to_stp2. eauto. eauto. econstructor.
    + eapply restp_widen. eapply IHhas_type; eauto. eapply stp_to_stp2; eauto. econstructor.

  - Case "TApp".
    remember (ttapp e t) as xe. induction H0; inversion Heqxe; subst.
    +
      remember t as T11.
      remember (teval n venv0 e) as tf.

      destruct tf as [rf|]; try solve by inversion.
      assert (res_type venv0 rf (TAll (TMem T11 T11) T12)) as HRF. SCase "HRF". subst. eapply IHn; eauto.
      inversion HRF as [? vf].

      subst t.
      destruct (invert_tabs venv0 vf T11 T12) as
          [env1 [tenv [x0 [y0 [T3 [T4 [EF [FRX [WF [HTY [STX STY]]]]]]]]]]]. eauto. eapply stp_to_stp2; eauto. econstructor.
      (* now we know it's a closure, and we have has_type evidence *)

      assert (res_type ((x0,vty venv0 T11)::env1) res (open (TSel x0) T4)) as HRY.
        SCase "HRY".
          subst. eapply IHn. eauto. eauto.
          (* wf_env x *) econstructor. eapply v_ty.
             eauto.
             eapply stp2_extend2. eauto. eauto. eauto.
      inversion HRY as [? vy].

      eapply not_stuck. eapply valtp_widen; eauto.

    + eapply restp_widen. eapply IHhas_type; eauto. eapply stp_to_stp2; eauto. econstructor.

  - Case "TAbs".
    remember (ttabs i t e) as xe. induction H0; inversion Heqxe; subst.
    + eapply not_stuck. eapply v_tabs; eauto. subst i. eauto. rewrite (wf_fresh venv0 env H1). eauto. eapply stp_to_stp2. eauto. eauto. econstructor.
    +  eapply restp_widen. eapply IHhas_type; eauto. eapply stp_to_stp2; eauto. econstructor.

Qed.

End FSUB.


Require Import Coq.Lists.List.
Import ListNotations.

Require Export Parser.DescriptionInd.
Require Export Parser.ShouldNotFollowDescr.

Definition should_not_follow_ind { A } (s: Syntax A) (k: token_class): Prop :=
  descr_ind (should_not_follow_descr k) s tt.

Lemma should_not_follow_ind_sound:
  forall A (s: Syntax A) k,
    should_not_follow_ind s k ->
    exists ts1 t ts2 v1 v2,
      matches s ts1 v1 /\
      matches s (ts1 ++ t :: ts2) v2 /\
      get_kind t = k
   .
Proof.
  induction 1;
    repeat light || lists || instantiate_any || destruct_match ||
           nullable_fun_spec || productive_fun_spec || apply_anywhere first_fun_sound || clear_in_dec;
    eauto 12 with matches.
Qed.

Lemma should_not_follow_ind_first:
  forall A (s: Syntax A) ts v1,
    matches s ts v1 ->
    forall t ts' v2,
      ts = nil ->
      matches s (t :: ts') v2 ->
      should_not_follow_ind s (get_kind t).
Proof.
  unfold should_not_follow_ind;
  induction 1;
    repeat light || invert_matches || invert_constructor_equalities || lists || app_cons_destruct;
    eauto 3 with descr_ind lights.

  - apply DisjInd0 with (some_rule tt);
      repeat
        light || lists || destruct_match || clear_in_dec || apply_anywhere first_fun_complete ||
        nullable_fun_spec.

  - apply DisjInd0 with (some_rule tt);
      repeat
        light || lists || destruct_match || clear_in_dec || apply_anywhere first_fun_complete ||
        nullable_fun_spec.

  - apply SeqInd2 with right_rule tt;
      repeat light || lists || destruct_match || nullable_fun_spec || productive_fun_spec;
      eauto.

  - apply SeqInd1 with left_rule tt;
      repeat light || lists || destruct_match || nullable_fun_spec || productive_fun_spec;
      eauto.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C P Q Q0 R : Universe, ((wd_ A B /\ (wd_ C B /\ (wd_ P B /\ (wd_ A C /\ (wd_ P Q /\ (wd_ B Q /\ (wd_ B Q0 /\ (wd_ P A /\ (wd_ P Q0 /\ (wd_ A Q0 /\ (col_ B C P /\ (col_ Q P Q0 /\ (col_ R B A /\ col_ P R Q0))))))))))))) -> col_ P Q R)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime A B C D Bprime Dprime : Universe, ((wd_ C O /\ (wd_ A O /\ (wd_ B O /\ (wd_ D O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ O Eprime /\ (wd_ Eprime C /\ (wd_ B O /\ (wd_ Eprime C /\ (wd_ Bprime O /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ O E D /\ (col_ B Eprime C /\ (col_ O Eprime C /\ (col_ O Eprime O /\ (col_ O Eprime Bprime /\ col_ O Eprime Dprime)))))))))))))))))))) -> col_ O E Eprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Coq.Lists.List.
Import ListNotations.
Require Import Tactics.
Require Import Sequence.
Require Import Relation.
Require Import Syntax.
Require Import Subst.
Require Import SimpSub.
Require Import Dynamic.
Require Import Promote.
Require Import Hygiene.
Require Import Rules.
Require Import DerivedRules.
Require Defs.
Require Import Obligations.
Require Import Morphism.
Require Import DefsEquiv.
Require Import Equivalence.
Require Import Equivalences.
Require Import Dots.

Require Import ValidationUtil.
Require Import Defined.
Require Import PageType.
Require Import SumLemmas.
Require Import NatLemmas.

Hint Rewrite def_nat def_zero def_succ def_natcase : prepare.

Lemma natForm_valid : natForm_obligation.
Proof.
prepare.
intro G.
apply tr_nattp_formation.
Qed.

Lemma natEq_valid : natEq_obligation.
Proof.
prepare.
intro G.
apply tr_nattp_formation.
Qed.

Lemma natFormUniv_valid : natFormUniv_obligation.
Proof.
prepare.
intros G i ext H.
apply (tr_univ_cumulative _ nzero); auto.
  {
  apply tr_nattp_formation_univ.
  }

  {
  unfold leqpagetp.
  rewrite -> unroll_leqtp.
  unfold nzero.
  rewrite -> sumcase_left.
  simpsub.
  apply tr_unittp_intro.
  }
Qed.

Lemma natEqUniv_valid : natEqUniv_obligation.
Proof.
prepare.
intros G i ext H.
apply (tr_univ_cumulative _ nzero); auto.
  {
  apply tr_nattp_formation_univ.
  }

  {
  unfold leqpagetp.
  rewrite -> unroll_leqtp.
  unfold nzero.
  rewrite -> sumcase_left.
  simpsub.
  apply tr_unittp_intro.
  }
Qed.

Lemma natElimEq_valid : natElimEq_obligation.
Proof.
prepare.
intros G a m n p q r s ext2 ext1 ext0 Hmn Hpq Hrs.
unfold natcase.
eapply (tr_sumtype_elim _ unittp); eauto.
  {
  apply (tr_subtype_elim _ nattp); auto.
  unfold nattp.
  apply tr_mu_unroll.
    {
    apply tr_sumtype_formation.
      {
      apply tr_unittp_istype.
      }

      {
      apply tr_hyp_tp; eauto using index_0.
      }
    }

    {
    apply tr_positive_nattp_body.
    }
  }
apply (tr_unittp_eta_hyp _ []).
simpsub.
auto.
Qed.

Lemma natElimEqtype_valid : natElimEqtype_obligation.
Proof.
prepare.
intros G a b c d m n ext2 ext1 ext0 Hmn Hab Hcd.
unfold natcase.
eapply (tr_sumtype_elim_eqtype _ unittp); eauto.
  {
  apply (tr_subtype_elim _ nattp); auto.
  unfold nattp.
  apply tr_mu_unroll.
    {
    apply tr_sumtype_formation.
      {
      apply tr_unittp_istype.
      }

      {
      apply tr_hyp_tp; eauto using index_0.
      }
    }

    {
    apply tr_positive_nattp_body.
    }
  }
unfold deqtype.
exploit (tr_unittp_eta_hyp G [] triv triv (subst sh1 (eqtype a b))) as H.
  {
  simpsub.
  exact Hab.
  }
cbn [length List.app under] in H.
simpsubin H.
exact H.
Qed.

Lemma zeroType_valid : zeroType_obligation.
Proof.
prepare.
intro G.
apply tr_nzero_nattp.
Qed.

Lemma succType_valid : succType_obligation.
Proof.
prepare.
intro G.
unfold Defs.succ.
rewrite -> def_arrow.
apply tr_pi_intro.
  {
  apply tr_nattp_formation.
  }
rewrite -> def_inr.
fold (@nsucc obj (var 0)).
simpsub.
apply tr_nsucc_nattp.
eapply hypothesis; eauto using index_0.
Qed.


Require Import core.Semantics.
Require Import core.Syntax.
Require Import core.modeling.ModelingSemantics.
Require Import core.modeling.ConcreteSyntax.
Require Import core.modeling.Parser.
Require Import core.Model.
Require Import core.TransformationConfiguration.
Require Import core.modeling.ModelingTransformationConfiguration.
Require Import core.properties.AdditivityRule.
Require Import String.
Require Import EqNat.
Require Import List.
Require Import Expressions.
Require Import core.utils.Utils.
Require Import PeanoNat.
Require Import Lia.

Section RuleIrrev.

Context {tc: TransformationConfiguration} {mtc: ModelingTransformationConfiguration tc}.

(* ClassMetamodel_eqClass_dec, add to type class of ModelingMetamodel *)
Definition eqb (t1 t2 : TargetModelClass) := true.

Definition output_relevent (r: ConcreteRule) (tp: TargetModelClass) : Prop.
Proof.
destruct (ConcreteRule_getConcreteOutputPattern r) eqn: op.
- exact False.
- specialize (map (ConcreteOutputPatternElement_getOutType) (c::l)).
  intro.
  exact (In tp X).
Qed.

Definition rule_relevent
  (x y: ConcreteRule) : Prop :=
  ConcreteRule_getName x = ConcreteRule_getName y /\
  forall tp, output_relevent x tp <-> output_relevent y tp .

Inductive Transformation_incl_relevent_rules  : list ConcreteRule -> list ConcreteRule -> Prop :=
  | incl_rules_nil : Transformation_incl_relevent_rules nil nil
  | incl_rules_diff : forall x y xs ys, Transformation_incl_relevent_rules xs ys
    -> rule_relevent x y
    -> Transformation_incl_relevent_rules (x::xs) (y::ys).


(****************************************************************************)
(* Copyright 2021 The Project Oak Authors                                   *)
(*                                                                          *)
(* Licensed under the Apache License, Version 2.0 (the "License")           *)
(* you may not use this file except in compliance with the License.         *)
(* You may obtain a copy of the License at                                  *)
(*                                                                          *)
(*     http://www.apache.org/licenses/LICENSE-2.0                           *)
(*                                                                          *)
(* Unless required by applicable law or agreed to in writing, software      *)
(* distributed under the License is distributed on an "AS IS" BASIS,        *)
(* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *)
(* See the License for the specific language governing permissions and      *)
(* limitations under the License.                                           *)
(****************************************************************************)

Require Import Coq.Lists.List.
Require Import Coq.ZArith.ZArith.
Require Import ExtLib.Structures.Monoid.
Require Import Cava.Util.List.
Require Import Cava.Types.
Import ListNotations.

(* Primitives have both semantic and netlist implementations *)
Inductive UnaryPrim : type -> type -> Type :=
| UnVecSlice: forall {t n} (start len: nat), UnaryPrim (Vec t n) (Vec t len)
| UnVecResize: forall {t n m}, UnaryPrim (Vec t n) (Vec t m)
| UnVecReverse: forall {t n}, UnaryPrim (Vec t n) (Vec t n)
| UnVecUncons: forall {t n}, UnaryPrim (Vec t (S n)) (t ** Vec t n)

| UnBitVecResize: forall {n m}, UnaryPrim (BitVec n) (BitVec m)
| UnBitVecShiftRight: forall {n}, nat -> UnaryPrim (BitVec n) (BitVec n)
| UnBitVecShiftLeft: forall {n}, nat -> UnaryPrim (BitVec n) (BitVec n)

| UnVecToTuple: forall {t n}, UnaryPrim (Vec t (S n)) (ntuple t n)

| UnBitVecNot: forall {n}, UnaryPrim (BitVec n) (BitVec n)

| UnBitNot: UnaryPrim Bit Bit
.

Inductive BinaryPrim : type -> type -> type -> Type :=
| BinBitOr: BinaryPrim Bit Bit Bit
| BinBitAnd: BinaryPrim Bit Bit Bit

| BinBitVecGte: forall {n}, BinaryPrim (BitVec n) (BitVec n) Bit

| BinBitVecOr: forall {n}, BinaryPrim (BitVec n) (BitVec n) (BitVec n)
| BinBitVecXor: forall {n}, BinaryPrim (BitVec n) (BitVec n) (BitVec n)
| BinBitVecAnd: forall {n}, BinaryPrim (BitVec n) (BitVec n) (BitVec n)
| BinBitVecAddU: forall {n}, BinaryPrim (BitVec n) (BitVec n) (BitVec n)
| BinBitVecSubU: forall {n}, BinaryPrim (BitVec n) (BitVec n) (BitVec n)
| BinBitVecMax: forall {n}, BinaryPrim (BitVec n) (BitVec n) (BitVec n)
| BinBitVecMin: forall {n}, BinaryPrim (BitVec n) (BitVec n) (BitVec n)

| BinVecIndex: forall {t n i}, BinaryPrim (Vec t n) (BitVec i) t
| BinVecCons: forall {t n}, BinaryPrim t (Vec t n) (Vec t (S n))
| BinVecConcat: forall {t n m}, BinaryPrim (Vec t n) (Vec t m) (Vec t (n + m))

(* drop leftmost element and push one element in right side, e.g. shifting left *)
| BinVecShiftInRight: forall {t n}, BinaryPrim (Vec t n) t (Vec t n)
| BinVecShiftInLeft: forall {t n}, BinaryPrim t (Vec t n) (Vec t n)

| BinEq: forall {x}, BinaryPrim x x Bit

.

Inductive TernaryPrim : type -> type -> type -> type -> Type :=
| TernVecReplace: forall {t n i}, TernaryPrim (Vec t n) (BitVec i) t (Vec t n)
.

Definition unary_semantics {x r} (prim: UnaryPrim x r)
  : denote_type x -> denote_type r :=
  match prim in UnaryPrim x r return denote_type x -> denote_type r with
  | @UnVecSlice t n start len =>
    fun x => resize default len (firstn len (skipn start x))
  | @UnVecResize t n m => fun x => resize default m x
  | @UnVecReverse t n => fun x => rev x

  | @UnVecUncons t n => fun x => (hd default x, tl x)

  | @UnBitVecResize n m => fun x => N.land x (N.ones (N.of_nat m))
  | UnBitVecShiftRight n => fun x => N.shiftr x (N.of_nat n)
  | @UnBitVecShiftLeft sz n => fun x => ((N.shiftl x (N.of_nat n)) mod (2 ^ (N.of_nat sz)))%N

  | @UnVecToTuple t n => vector_as_tuple n t
  | @UnBitVecNot n => fun x => N.lnot x (N.of_nat n)

  | UnBitNot => negb
  end.

Definition binary_semantics {x y r} (prim: BinaryPrim x y r)
  : denote_type x -> denote_type y -> denote_type r :=
  match prim in BinaryPrim x y r return denote_type x -> denote_type y -> denote_type r with
  | BinBitOr => orb
  | BinBitAnd => andb

  | BinBitVecGte => fun x y => (y <=? x)%N

  | @BinBitVecOr n => N.lor
  | @BinBitVecXor n => N.lxor
  | @BinBitVecAnd n => N.land
  | @BinBitVecAddU n => fun x y => ((x + y) mod (2 ^ (N.of_nat n)))%N
  | @BinBitVecSubU n => fun x y => ((x + 2 ^ N.of_nat n - y) mod (2 ^ (N.of_nat n)))%N
  | @BinVecIndex t len i => fun x n => nth (N.to_nat n) (resize default len x) default
  | @BinBitVecMax n => fun x y => (if x <=? y then y else x)%N
  | @BinBitVecMin n => fun x y => (if x <=? y then x else y)%N
  | BinVecCons => fun x y => x :: y
  | BinVecConcat => fun x y => x ++ y
  | @BinVecShiftInRight t n => (fun xs x => tl (xs ++ [x]))
  | @BinVecShiftInLeft t n => (fun x xs => removelast (x :: xs))
  | BinEq => eqb
  end%list.

Definition ternary_semantics {x y z r} (prim: TernaryPrim x y z r)
  : denote_type x -> denote_type y -> denote_type z -> denote_type r :=
  match prim in TernaryPrim x y z r return denote_type x -> denote_type y -> denote_type z -> denote_type r with
  | TernVecReplace => fun ls i x => replace (N.to_nat i) x ls
  end.