Require Import List.
Require Import Coq.Arith.Compare_dec.
Require Import Coq.Arith.Arith_base.
Load indtype.

(*** terms and helper defs ***)

Definition level := nat.

Inductive Term : Set :=
| Prp : Term
| Tp : level -> Term
| Pi : Term -> Term -> Term
| IndType : IndInfo -> TermList -> Term
| Var : nat -> Term
| App : Term -> Term -> Term
| Lam : Term -> Term -> Term
| CtorApp : IndInfo -> nat -> TermList -> Term
| Elim : ElimInfo -> TermList -> Term -> Term
with IndInfo :=
| MkIndInfo : Term -> (nat -> TermOpt) -> IndInfo
with ElimInfo :=
| MkElimInfo : IndInfo -> nat -> Term -> (nat -> TermOpt) -> ElimInfo
with TermOpt :=
| SomeTerm : Term -> TermOpt
| NoTerm : TermOpt
with TermList :=
| TL_nil : TermList
(* README: TermLists cons to the right *)
| TL_cons : TermList -> Term -> TermList
.

Definition TermMSeq := nat -> TermOpt.

(* Definition Ctx : Set := list Term. *)
(* Definition Ctx : Set := TermList. *)

(***
 *** operations on my fake lists (stupid Coq)
 ***)

Fixpoint TL_len (l : TermList) :=
  match l with
    | TL_nil => 0
    | TL_cons l' _ => S (TL_len l')
  end.

Fixpoint TL_app (l1 l2 : TermList) :=
  match l2 with
    | TL_nil => l1
    | TL_cons l2' M => TL_cons (TL_app l1 l2') M
  end.

Fixpoint TL_nth_or_fail (n : nat) (l : TermList) : Term + { TL_len l <= n } :=
  match n as n', l as l' return Term + { TL_len l' <= n' } with
    | n, TL_nil => inright _ (le_O_n n)
    | 0, TL_cons _ M => inleft _ M
    | (S n'), (TL_cons l' _) =>
      match TL_nth_or_fail n' l' with
        | inleft M => inleft _ M
        | inright pf => inright _ (le_n_S _ _ pf)
      end
  end.

Inductive TL_isNth (T : Term) : nat -> TermList -> Set :=
| isNth_TL_base (l : TermList) : TL_isNth T 0 (TL_cons l T)
| isNth_TL_cons (n : nat) (T' : Term) (l : TermList)
  : TL_isNth T n l -> TL_isNth T (S n) (TL_cons l T').

(***
 *** Helper definitions for manipulating terms
 ***)

Fixpoint apply (M : Term) (l : TermList) {struct l} : Term :=
  match l with
    | TL_nil => M
    | TL_cons l' N => App (apply M l') N
  end.

Definition apply1opt (M : Term) (Nopt : TermOpt) : Term :=
  match Nopt with
    | NoTerm => M
    | SomeTerm N => App M N
  end.

Fixpoint piMulti (As : TermList) (B : Term) : Term :=
  match As with
    | TL_nil => B
    | TL_cons As' An => piMulti As' (Pi An B)
  end.

(* Pattern-match on a term of the form (M N1 .. Nn) and return a pair
   of (M, N1 .. Nn)
 *)
Fixpoint matchApply (M : Term) : Term * TermList :=
  match M with
    | App M1 M2 => (fst (matchApply M1), TL_cons (snd (matchApply M1)) M2)
    | _ => (M, TL_nil)
  end.

(* Match a term of the form (x1:A1) -> .. -> (xn:An) -> M (N1 .. Nm) and
   return (As ++ A1 .. An, M, N1 .. Nm)
 *)
Fixpoint matchPiApplyH (As : TermList) (M : Term)
  : TermList * (Term * TermList) :=
  match M with
    | Pi A B => matchPiApplyH (TL_cons As A) B
    | _ => (As, matchApply M)
  end.

Definition matchPiApply (M : Term) := matchPiApplyH TL_nil M.
Definition matchPiApply_Pis (M : Term) := fst (matchPiApply M).
Definition matchPiApply_head (M : Term) := fst (snd (matchPiApply M)).
Definition matchPiApply_args (M : Term) := snd (snd (matchPiApply M)).

(***
 *** helper definitions for variable occurrences
 ***)

Inductive occurs (n : nat) : Term -> Set :=
(* no occurrences for Sort *)
| OccursPi1 (A B : Term) : occurs n A -> occurs n (Pi A B)
| OccursPi2 (A B : Term) : occurs (S n) B -> occurs n (Pi A B)
| OccursIndType1 (info : IndInfo) (params : TermList)
  : occursInfo n info -> occurs n (IndType info params)
| OccursIndType2 (info : IndInfo) (params : TermList)
  : occursList n params -> occurs n (IndType info params)
| OccursVar : occurs n (Var n)
| OccursApp1 (M N : Term) : occurs n M -> occurs n (App M N)
| OccursApp2 (M N : Term) : occurs n N -> occurs n (App M N)
| OccursLam1 (A M : Term) : occurs n A -> occurs n (Lam A M)
| OccursLam2 (A M : Term) : occurs (S n) M -> occurs n (Lam A M)
| OccursCtorApp1 (info : IndInfo) (i : nat) (params : TermList)
  : occursInfo n info -> occurs n (CtorApp info i params)
| OccursCtorApp2 (info : IndInfo) (i : nat) (params : TermList)
  : occursList n params -> occurs n (CtorApp info i params)
| OccursElim1 (einfo : ElimInfo) (params : TermList) (scrut : Term)
  : occursElimInfo n einfo -> occurs n (Elim einfo params scrut)
| OccursElim2 (einfo : ElimInfo) (params : TermList) (scrut : Term)
  : occursList n params -> occurs n (Elim einfo params scrut)
| OccursElim3 (einfo : ElimInfo) (params : TermList) (scrut : Term)
  : occurs n scrut -> occurs n (Elim einfo params scrut)
with occursMSeq (n : nat) : TermMSeq -> Set :=
| OccursSeq (patts : TermMSeq) (j : nat)
  : occursOpt n (patts j) -> occursMSeq n patts
with occursList (n : nat) : TermList -> Set :=
| OccursListBase (l : TermList) (M : Term)
  : occurs n M -> occursList n (TL_cons l M)
| OccursListCons (l : TermList) (M : Term)
  : occursList n l -> occursList n (TL_cons l M)
with occursOpt (n : nat) : TermOpt -> Set :=
| OccursOpt (M : Term) : occurs n M -> occursOpt n (SomeTerm M)
with occursInfo (n : nat) : IndInfo -> Set :=
| OccursMkIndInfo1 (kind : Term) (ctorTypes : TermMSeq)
  : occurs n kind -> occursInfo n (MkIndInfo kind ctorTypes)
| OccursMkIndInfo2 (kind : Term) (ctorTypes : TermMSeq)
  : occursMSeq n ctorTypes -> occursInfo n (MkIndInfo kind ctorTypes)
with occursElimInfo (n : nat) : ElimInfo -> Set :=
| OccursMkElimInfo1 (info : IndInfo) (i : nat) (P : Term) (patts : TermMSeq)
  : occursInfo n info -> occursElimInfo n (MkElimInfo info i P patts)
| OccursMkElimInfo2 (info : IndInfo) (i : nat) (P : Term) (patts : TermMSeq)
  : occurs n P -> occursElimInfo n (MkElimInfo info i P patts)
| OccursMkElimInfo3 (info : IndInfo) (i : nat) (P : Term) (patts : TermMSeq)
  : occursMSeq n patts -> occursElimInfo n (MkElimInfo info i P patts)
.

Inductive notOccurs (n : nat) : Term -> Set :=
| NotOccursPrp (i : nat) : notOccurs n Prp
| NotOccursTp (i : nat) : notOccurs n (Tp i)
| NotOccursPi (A B : Term)
  : notOccurs n A -> notOccurs (S n) B -> notOccurs n (Pi A B)
| NotOccursIndType (info : IndInfo) (params : TermList)
  : notOccursInfo n info -> notOccursList n params ->
    notOccurs n (IndType info params)
| NotOccursVar (m : nat) : (n <> m) -> notOccurs n (Var m)
| NotOccursApp (M N : Term)
  : notOccurs n M -> notOccurs n N -> notOccurs n (App M N)
| NotOccursLam (A M : Term)
  : notOccurs n A -> notOccurs (S n) M -> notOccurs n (Lam A M)
| NotOccursCtorApp (info : IndInfo) (i : nat) (params : TermList)
  : notOccursInfo n info -> notOccurs n (CtorApp info i params)
| NotOccursElim (einfo : ElimInfo) (params : TermList) (scrut : Term)
  : notOccursElimInfo n einfo -> notOccursList n params -> notOccurs n scrut ->
    notOccurs n (Elim einfo params scrut)
with notOccursList (n : nat) : TermList -> Set :=
| NotOccursNil : notOccursList n TL_nil
| NotOccursCons (l : TermList) (M : Term)
  : notOccursList n l -> notOccurs n M -> notOccursList n (TL_cons l M)
with notOccursTermOpt (n : nat) : TermOpt -> Set :=
| NotOccursNoTerm : notOccursTermOpt n NoTerm
| NotOccursSomeTerm (M : Term) :
  notOccurs n M -> notOccursTermOpt n (SomeTerm M)
with notOccursMSeq (n : nat) : TermMSeq -> Set :=
| NotOccursMSeq (seq : TermMSeq)
  : (forall (i : nat), notOccursTermOpt n (seq i)) -> notOccursMSeq n seq
with notOccursInfo (n : nat) : IndInfo -> Set :=
| NotOccursMkIndInfo (kind : Term) (ctorTypes : TermMSeq)
  : notOccurs n kind -> notOccursMSeq n ctorTypes ->
    notOccursInfo n (MkIndInfo kind ctorTypes)
with notOccursElimInfo (n : nat) : ElimInfo -> Set :=
| NotOccursMkElimInfo (info : IndInfo) (i : nat) (P : Term) (patts : TermMSeq)
  : notOccursInfo n info -> notOccurs n P -> notOccursMSeq n patts ->
    notOccursElimInfo n (MkElimInfo info i P patts)
.

(*** substitution and lifting ***)

(* README: k is the amount we are incrementing the variables, and n is the
 * number of variable bindings under which we have traversed so far *)
Fixpoint lift (n k : nat) (M : Term) {struct M} : Term :=
  match M with
    | Prp => Prp
    | Tp i => Tp i
    | Pi A B => Pi (lift n k A) (lift (S n) k B)
    | IndType info params =>
      IndType (liftIndInfo n k info) (liftList n k params)
    | Var i =>
      match le_lt_dec n i with
        | left _ => Var (i + k) (* case: i >= n *)
        | right _ => Var i (* case: i < n *)
      end
    | App M1 M2 => App (lift n k M1) (lift n k M2)
    | Lam A M1 => Lam (lift n k A) (lift (S n) k M1)
    | CtorApp info i params =>
      CtorApp (liftIndInfo n k info) i (liftList n k params)
    | Elim einfo params scrut =>
      Elim (liftElimInfo n k einfo) (liftList n k params) (lift n k scrut)
  end
with liftList (n k : nat) (l : TermList) {struct l} :=
  match l with
    | TL_nil => TL_nil
    | TL_cons l' M => TL_cons (liftList n k l') (lift n k M)
  end
with liftOpt (n k : nat) (M_opt : TermOpt) {struct M_opt} :=
  match M_opt with
    | SomeTerm M => SomeTerm (lift n k M)
    | NoTerm => NoTerm
  end
with liftIndInfo (n k : nat) (info : IndInfo) {struct info} :=
  match info with
    | MkIndInfo sort ctors =>
      MkIndInfo (lift n k sort) (fun i => liftOpt n k (ctors i))
  end
with liftElimInfo (n k : nat) (einfo : ElimInfo) :=
  match einfo with
    MkElimInfo info i P patts =>
      MkElimInfo (liftIndInfo n k info) i (lift n k P)
      (fun i => liftOpt n k (patts i))
  end
  .

(* Grr, Coq cannot handle liftMSeq in the above mutal definitions... *)
Definition liftMSeq (n k : nat) (seq : TermMSeq) :=
  fun i => liftOpt n k (seq i).

Definition Subst := TermList.

(* README: n is the number of binders we have traversed *)
Fixpoint substH (n : nat) (s : Subst) (M : Term) {struct M} : Term :=
  match M with
    | Prp => Prp
    | Tp i => Tp i
    | Pi A B => Pi (substH n s A) (substH (S n) s B)
    | IndType info params =>
      IndType (substIndInfo n s info) (substList n s params)
    | Var i =>
      match le_lt_dec n i with
        | right _ => Var i (* case: i < n *)
        | left _ => (* case: i >= n *)
          match TL_nth_or_fail (i - n) s with
            | inleft N => lift 0 n N
            | _ => Var (i + n)
          end
      end
    | App M1 M2 => App (substH n s M1) (substH n s M2)
    | Lam A M1 => Lam (substH n s A) (substH (S n) s M1)
    | CtorApp info i params =>
      CtorApp (substIndInfo n s info) i (substList n s params)
    | Elim einfo params scrut =>
      Elim (substElimInfo n s einfo) (substList n s params) (substH n s scrut)
  end
with substList (n : nat) (s : Subst) (l : TermList) :=
  match l with
    | TL_nil => TL_nil
    | TL_cons l' M => TL_cons (substList n s l') (substH n s M)
  end
with substOpt (n : nat) (s : Subst) (M_opt : TermOpt) :=
  match M_opt with
    | SomeTerm M => SomeTerm (substH n s M)
    | NoTerm => NoTerm
  end
with substIndInfo (n : nat) (s : Subst) (info : IndInfo) :=
  match info with
    | MkIndInfo sort ctorTypes =>
      MkIndInfo (substH n s sort) (fun i => substOpt n s (ctorTypes i))
  end
with substElimInfo (n : nat) (s : Subst) (einfo : ElimInfo) :=
  match einfo with
    | MkElimInfo info i P patts =>
      MkElimInfo (substIndInfo n s info) i (substH n s P)
      (fun i => substOpt n s (patts i))
  end
.

Definition substMSeq (n : nat) (s : Subst) (seq : TermMSeq) :=
  (fun i => substOpt n s (seq i)).

Definition subst (s : Subst) (M : Term) := substH 0 s M.
Definition substOne (N M : Term) := substH 0 (TL_cons TL_nil N) M.

(***
 *** helper functions defined in terms of substitution
 ***)

(* Return the result type of the application of a function of type
   (x1:A1) -> .. -> (xn:An) -> B to a list of arguments N1 .. Nn;
   i.e., substitute each Ni for xi in B. Return NoTerm if the function
   type does not have enough Pi's for the given argument list.
 *)
Fixpoint typeApply (funtp : Term) (args : TermList) : TermOpt :=
  match args with
    | TL_nil => SomeTerm funtp
    | TL_cons args' N =>
      match funtp with
        | Pi A B => match typeApply funtp args' with
                      | SomeTerm Bres => SomeTerm (substOne N Bres)
                      | NoTerm => NoTerm
                    end
        | _ => NoTerm
      end
  end.

(***
 *** definitions for inductive types
 ***)

(* Inductive types are given as a pair (kind, ctorTypes) of the kind
   of the inductive type constructor itself and a sequence of the
   types of the constructors. To be well-formed, kind must be of the
   form (x1:A1) -> ... -> (xn:An) -> s such that each Ai has sort si
   and, if s is (Tp j), then each Ai has type (Tp j). Each type in
   ctorTypes must be (x1:B1) -> ... -> (xm:Bm) -> X M1 .. Mn, where: X
   is deBruijn index 0 outside the binding for x1; each Bi has the
   same type (Tp j) as in the kind, or any sort sj for impredicative
   types; and where each M has the corresponding A type in kind.

   Each Bi must also be strictly positive in X, meaning that, if it
   contains X, it has the form (y1:C1) -> ... -> (yp:Cp) -> X N1 .. Nn
   where none of the C's or N's have X free. Note that, as an
   additional technical requirement to simplify the proofs later on,
   we also require that any yi whose type Ci does contain X (in the
   above form) does not occur in any later C's or in any of the N's.
   This should in fact always hold anyway for strictly positive types,
   since there is nothing in scope that has a type which refers to X,
   the return type of yi, and thus any later term containing y would
   have to mention the type of yi, which would contain X, which is
   disallowed by positivity. We do not prove this, however,
 *)

(**
 ** strict positivity
 **)

(* Captures the fact that a term is X M1 .. Mn for some arguments Mi
   that do not contain X free.
 *)
Inductive isXApp (n : nat) : Term -> Set :=
  | isXAppBase : isXApp n (Var n)
  | isXAppStep (M N : Term) :
    isXApp n M -> notOccurs n N -> isXApp n (App M N)
.

(* Defines positivity for recursive argument types, meaning that the
   type has the form (y1:C1) -> ... -> (yp:Cp) -> X N1 .. Nn where
   none of the C's have X free.
 *)
Inductive positiveArg (n : nat) : Term -> Set :=
| PosArg (A B : Term)
  : notOccurs n A -> positiveArg (S n) B -> positiveArg n (Pi A B)
| PosArgEnd (M : Term) : isXApp n M -> positiveArg n M
.

(* Defines constructor types that are strictly positive for deBruijn
   index n.
 *)
Inductive positiveN (n : nat) : Term -> Set :=
| Positive_Rec (A B : Term)
  : positiveArg n A -> positiveN (S n) B -> positiveN n (Pi A B)
| Positive_NonRec (A B : Term)
  : notOccurs n A -> positiveN (S n) B -> positiveN n (Pi A B)
| Positive_End (A : Term) : isXApp n A -> positiveN n A
.

Definition positive := positiveN 0.

(**
 ** building the type of an eliminator
 **)

(* Helper function for elimtpCtor: builds the type of the recursive
   calls. See comments for elimtpCtor below. NOTE: This also gives the
   type of the result of buildRecElimCall.
 *)
Fixpoint buildRecCallType (n : nat) (A P xapp : Term) : TermOpt :=
  match A with
    | Pi C Arest =>
      match buildRecCallType (S n) Arest (lift 0 1 P)
        (App (lift 0 1 xapp) (Var 0))
      with
        | NoTerm => NoTerm
        | SomeTerm res => SomeTerm (Pi C res)
      end
    | _ => match fst (matchApply A) with
             | Var i => match eq_nat_dec i n with
                          | left _ =>
                            SomeTerm (App
                              (apply P (snd (matchApply A)))
                              xapp)
                          | right _ => NoTerm
                        end
             | _ => NoTerm
           end
  end.

(* Build the type of the "recursive step" of a constructor of type ctp
   for an inductive hypothesis predicate P. In more detail, ctp should
   have the form (x1:A1) -> .. -> (xn:An) -> X M1 .. Mm, where X is
   the variable corresponding to deBruijn index 0 outside ctp. The
   recursive step should then have type

   (x1:A1) -> (y1:B1)? -> .. (xn:An) -> (yn:Bn)? ->
   P M1 .. Mm (c x1 .. xn)

   where c is the constructor whose recursive step type we are
   building and each Bi is, intuitively, the type of the result of a
   recursive call on xi. To define Bi, we test to see if the type Ai
   has the form (z1:C1) -> .. -> (zn:Cn) -> X N1 .. Nn; if so,
   then Bi is defined as

   (z1:C1) -> .. -> (zn:Cn) -> P N1 .. Nn (xi z1 .. zn)

   Otherwise, the binding (yi:Bi) is omitted.

   To define this recursively, elimtpCtor takes ctp along with: the
   predicate P; the numbers n and m of xi's and yi's, respectively,
   that we have already added outside the current point in the
   computation; and a term capp, which is c applied to all of the xi's
   that have already been seen.

   NOTE: ctp has *not* been lifted into the yi bindings; this is to
   avoid a recursive call on (lift 0 1 ctp') in the first case. Thus,
   any uses of components matched in ctp must be lifted by m.
 *)

Fixpoint elimtpCtor (n m : nat) (ctp P capp : Term) {struct ctp} : Term :=
  match ctp with
    | Pi A ctp' =>
      Pi (lift 0 m A) (
        match buildRecCallType ((S n)+m) (lift 0 (S m) A) (lift 0 1 P) (Var 0)
        with
          | SomeTerm B =>
            Pi B (elimtpCtor (S n) (S m) ctp' (lift 0 2 P)
              (App (lift 0 2 capp) (Var 1)))
          | NoTerm =>
            (elimtpCtor (S n) m ctp' (lift 0 1 P) (App (lift 0 1 capp) (Var 0)))
        end
      )
    | _ => App (apply P (snd (matchApply ctp))) capp
  end.

(**
 ** iota-reduction
 **)

(* The iota-rule is defined like this:

   elim info i P f (M1 .. Mm) (cj N1 .. Nn)
   -->
   (f j) N1 N1'? N2 N2'? ...

   If the type of Nk has the form (x1:A1) .. (xp:Ap) -> a P1 .. Pm,
   then Nk'?  becomes a recursive call to the eliminator, of the form

   \x1 .. xp -> elim info i P f (P1 .. Pm) (Nk x1 .. xp)

   Otherwise, Nk'? is NoTerm, i.e., there is no argument for it.
*)

(* Build \x1 .. xp -> elim info i P f (P1 .. Pm) (Nk x1 .. xp) from
   the type (x1:A1) .. (xp:Ap) -> a P1 .. Pm and the terms Nk and the
   eliminator (elim info i P f)
*)
Fixpoint buildRecElimCall (n : nat) (Ntp N : Term) (einfo : ElimInfo)
  : TermOpt :=
  match Ntp with
    | Pi A B =>
      match buildRecElimCall (S n) B (App (lift 0 1 N) (Var 0))
        (liftElimInfo 0 1 einfo)
      with
        | SomeTerm recResult => SomeTerm (Lam A recResult)
        | NoTerm => NoTerm
      end
    | _ => match fst (matchApply Ntp) with
             | Var i => match eq_nat_dec i n with
                          | left _ =>
                            SomeTerm (Elim einfo (snd (matchApply Ntp)) N)
                          | right _ => NoTerm
                        end
             | _ => NoTerm
           end
  end.

(* Build the term "(f j) N1 N1'? N2 N2'? ...", the result of iota
   reduction, from "elim info i P f (M1 .. Mm) (cj N1 .. Nn)", where M
   = (f j), ctp = the type of cj, cargs = N1 .. Nn, and einfo is the
   ElimInfo containing (info, i, P, f).

   Typing Invariants: M has type Mtp = elimtp P cj ctp, i.e., the type a
   "recursive step" for a constructor of type ctp; and cargs match
   some prefix of the argument types of ctp, i.e., typeApply ctp cargs
   is not NoTerm.

   Typing Result: The resulting term should have the following type:
   elimtpCtor 0 0 (typeApply ctp cargs) P ((\x1 .. xn -> cj x1 .. xn) cargs)
 *)
Fixpoint buildIotaResult (ctp M : Term) (cargs : TermList) (einfo : ElimInfo)
  {struct cargs} : Term :=
  match cargs with
    | TL_nil => M
    | TL_cons cargs' Ni =>
      match typeApply ctp cargs with
        | SomeTerm (Pi A B) =>
          apply1opt (buildIotaResult ctp M cargs' einfo)
          (buildRecElimCall 0 A Ni einfo)
        | _ =>
          (* README: should never happen *)
          (buildIotaResult ctp M cargs' einfo)
      end
  end.

FIXME HERE:

(* README: we assume there is some "ambient" ctx and an argCtx for the
 * non-recursive args in the current constructor; elimF then takes in ctx',
 * some params that are well-typed in (ctx,argCtx,ctx'), and some scrut
 * that is well-typed in (ctx,ctx'), and returns a term well-typed in
 * (ctx,ctx'). *)
Definition elimRecArg (elimF : Ctx -> TermList -> Term -> Term)
  (r : RecTp) (recArg : Term) :=
  match r with
    | MkRecTp ctx indices =>
      makeLam ctx (elimF ctx indices
        (makeAppToVars (lift 0 (ctxLen ctx) recArg) 0 ctx))
  end.

(* README: elimRecArgsH takes each recursive argument recArg supplied
 * to a constructor and returns both recArg and the result of a
 * recursive call (using elimF) on recArg *)
Fixpoint elimRecArgsH (elimF : Ctx -> TermList -> Term -> Term)
  (rs : RecTpList) (recArgs : TermList) : option TermList :=
  match rs, recArgs with
    | RTL_nil, TL_nil => Some TL_nil
    | RTL_cons rs' r, TL_cons recArgs' recArg =>
      match elimRecArgsH elimF rs' recArgs' with
        | None => None
        | Some ret =>
          Some (TL_cons (TL_cons ret recArg) (elimRecArg elimF r recArg))
      end
    | _, _ => None
  end.

Definition elimRecArgs (info : IndInfo) (fs : TermList) (i : nat)
  (args : TermList) (recArgs : TermList) : option TermList :=
  match nthCtorType i info with
    | None => None
    | Some (MkCtorType ctx rs indices) =>
      elimRecArgsH (fun ctx params scrut =>
        Elim (liftIndInfo 0 (ctxLen ctx) info)
        (liftTermList 0 (ctxLen ctx) fs)
        (substTermList (ctxLen ctx) args params)
        scrut)
      rs recArgs
  end.

(*
Definition elimRecArg (info : IndInfo) (fs : TermList) (args : TermList) (r : RecTp) (recArg : Term) :=
  match r with
    | MkRecTp ctx indices =>
      makeLam ctx (
        Elim (liftIndInfo 0 (ctxLen ctx) info)
        (liftTermList 0 (ctxLen ctx) fs)
        (substTermList (ctxLen ctx) args indices)
        (makeAppToVars (lift 0 (ctxLen ctx) recArg) 0 ctx)
      )
  end.

Fixpoint elimRecArgsH (info : IndInfo) (fs : TermList) (args : TermList)
  (rs : RecTpList) (recArgs : TermList) : option TermList :=
  match rs, recArgs with
    | RTL_nil, TL_nil => Some TL_nil
    | RTL_cons rs' r, TL_cons recArgs' recArg =>
      match elimRecArgsH info fs args rs' recArgs' with
        | None => None
        | Some ret => Some (TL_cons ret (elimRecArg info fs args r recArg))
      end
    | _, _ => None
  end.

Definition elimRecArgs (info : IndInfo) (fs : TermList) (i : nat)
  (args : TermList) (recArgs : TermList) : option TermList :=
  match nthCtorType i info with
    | None => None
    | Some (MkCtorType ctx rs indices) =>
      elimRecArgsH info fs args rs recArgs
  end.
*)

Inductive rrto : Term -> Term -> Set :=
| RR_Beta : forall A M N, rrto (App (Lam A M) N) (substOne N M)
| RR_iota : forall info info' fs f params i args recArgs elimArgs,
  nth_or_fail_TL i fs = inleft _ f ->
  elimRecArgs info fs i args recArgs = Some elimArgs ->
  rrto (Elim info fs params (CtorApp info' i args recArgs))
  (makeApp (makeApp f args) elimArgs)
| RR_Pi1 : forall A A' B, rrto A A' -> rrto (Pi A B) (Pi A' B)
| RR_Pi2 : forall A B B', rrto B B' -> rrto (Pi A B) (Pi A B')
| RR_App1 : forall f f' a , rrto f f' -> rrto (App f a) (App f' a)
| RR_App2 : forall f a a', rrto a a' -> rrto (App f a) (App f a')
| RR_Lam1 : forall A A' M, rrto A A' -> rrto (Lam A M) (Lam A' M)
| RR_Lam2 : forall A M M', rrto M M' -> rrto (Lam A M) (Lam A M')
| RR_Elim1 : forall info info' fs params scrut,
  rrtoIndInfo info info' ->
    rrto (Elim info fs params scrut) (Elim info' fs params scrut)
| RR_Elim2 : forall info fs fs' params scrut,
  rrtoTermList fs fs' ->
    rrto (Elim info fs params scrut) (Elim info fs' params scrut)
| RR_Elim3 : forall info fs params params' scrut,
  rrtoTermList params params' ->
    rrto (Elim info fs params scrut) (Elim info fs params' scrut)
| RR_Elim4 : forall info fs params scrut scrut',
  rrto scrut scrut' ->
    rrto (Elim info fs params scrut) (Elim info fs params scrut')
with rrtoTermList : TermList -> TermList -> Set :=
| RR_TL_cons1 : forall M l l',
  rrtoTermList l l' -> rrtoTermList (TL_cons l M) (TL_cons l' M)
| RR_TL_cons2 : forall M M' l,
  rrto M M' -> rrtoTermList (TL_cons l M) (TL_cons l M')
with rrtoCtx : Ctx -> Ctx -> Set :=
| RR_Ctx_cons1 : forall ctx ctx' M,
  rrtoCtx ctx ctx' -> rrtoCtx (Ctx_cons ctx M) (Ctx_cons ctx' M)
| RR_Ctx_cons2 : forall ctx M M',
  rrto M M' -> rrtoCtx (Ctx_cons ctx M) (Ctx_cons ctx M')
with rrtoIndInfo : IndInfo -> IndInfo -> Set :=
| RR_MkIndInfo1 : forall ctx ctx' i ctps,
  rrtoCtx ctx ctx' ->
  rrtoIndInfo (MkIndInfo ctx i ctps) (MkIndInfo ctx' i ctps)
| RR_MkIndInfo2 : forall ctx i ctps ctps',
  rrtoCtorTypeList ctps ctps' ->
  rrtoIndInfo (MkIndInfo ctx i ctps) (MkIndInfo ctx i ctps')
with rrtoCtorTypeList : CtorTypeList -> CtorTypeList -> Set :=
| RR_CTL_cons1 : forall ctp l l',
  rrtoCtorTypeList l l' -> rrtoCtorTypeList (CTL_cons l ctp) (CTL_cons l' ctp)
| RR_CTL_cons2 : forall ctp ctp' l,
  rrtoCtorType ctp ctp' -> rrtoCtorTypeList (CTL_cons l ctp) (CTL_cons l ctp')
with rrtoCtorType : CtorType -> CtorType -> Set :=
| RR_MkCtorType1 : forall ctx ctx' rs indices,
  rrtoCtx ctx ctx' ->
  rrtoCtorType (MkCtorType ctx rs indices) (MkCtorType ctx' rs indices)
| RR_MkCtorType2 : forall ctx rs rs' indices,
  rrtoRecTpList rs rs' ->
  rrtoCtorType (MkCtorType ctx rs indices) (MkCtorType ctx rs' indices)
| RR_MkCtorType3 : forall ctx rs indices indices',
  rrtoTermList indices indices' ->
  rrtoCtorType (MkCtorType ctx rs indices) (MkCtorType ctx rs indices')
with rrtoRecTpList : RecTpList -> RecTpList -> Set :=
| RR_RTL_cons1 : forall r l l',
  rrtoRecTpList l l' -> rrtoRecTpList (RTL_cons l r) (RTL_cons l' r)
| RR_RTL_cons2 : forall r r' l,
  rrtoRecTp r r' -> rrtoRecTpList (RTL_cons l r) (RTL_cons l r')
with rrtoRecTp : RecTp -> RecTp -> Set :=
| RR_MkRecTp1 : forall ctx ctx' indices,
  rrtoCtx ctx ctx' ->
  rrtoRecTp (MkRecTp ctx indices) (MkRecTp ctx' indices)
| RR_MkRecTp2 : forall ctx indices indices',
  rrtoTermList indices indices' ->
  rrtoRecTp (MkRecTp ctx indices) (MkRecTp ctx indices')
.

Inductive conv : Term -> Term -> Set :=
| conv_refl : forall M , conv M M
| conv_stepR : forall M1 M2 M3 , rrto M1 M2 -> conv M2 M3 ->
  conv M1 M3
| conv_stepL : forall M1 M2 M3 , rrto M2 M1 -> conv M2 M3 ->
  conv M1 M3
.

(*** sub-typing ***)

Inductive subtype : Term -> Term -> Set :=
| SubTp_Refl : forall T , subtype T T
| SubTp_Sort : forall i j , i <= j -> subtype (Sort i) (Sort j)
| SubTp_Pi : forall A B B' , subtype B B' -> subtype (Pi A B) (Pi A B')
.

(*** typing ***)

(* translates a RecTp into the type of the eliminator for that RecTp
 *
 * README: we assume an "ambient" ctx, an argCtx that quantifies over
 * the non-recursive args for the current constructor, and an indCtx
 * that quantifies over the index args to the current inductive type,
 * where the latter two must be well-formed relative to ctx; we then
 * assume that r is well-typed w.r.t. (ctx,argCtx) and that B is
 * well-typed w.r.t. (ctx,argCtx,indCtx, --some IndType-- ), and
 * return a term that is well-typed in (ctx,argCtx, 0 : r)
 *)
Definition recTp2ElimType (r : RecTp) B :=
  match r with
    | MkRecTp ctx indices =>
      makePi (liftCtx 0 1 ctx) (substH ((ctxLen ctx) + 1)
        (TL_cons (liftTermList (ctxLen ctx) 1 indices)
          (makeAppToVars (Var (ctxLen ctx)) 0 ctx))
        (lift 0 ((ctxLen ctx) + 1) B))
  end.

(* README: we make the same context assumptions as recTp2ElimType and,
 * in addition, that info is well-typed in the "ambient" ctx. *)
Fixpoint recTps2ElimCtx (info : IndInfo) (argCtx : Ctx) (rs : RecTpList) B :=
  match rs with
    | RTL_nil => Ctx_nil
    | RTL_cons rs' r =>
      Ctx_cons (Ctx_cons (recTps2ElimCtx info argCtx rs' B)
        (lift 0 (ctxLen (recTps2ElimCtx info argCtx rs' B))
          (recTp2Type info argCtx r)))
      (lift 1 (ctxLen (recTps2ElimCtx info argCtx rs' B)) (recTp2ElimType r B))
  end.

(* README: same context assumptions as recTp2sElimCtx, but ctp is
 * well-typed w.r.t. the "ambient" ctx and B is well-typed w.r.t.
 * (ctx,indCtx, --some IndType--); we return a term that is well-typed
 * w.r.t. the ambient ctx *)
Definition ctorElimType (info : IndInfo) (indCtx : Ctx) (i : nat) (ctp : CtorType) B :=
  match ctp with
    | MkCtorType argCtx rs indices =>
      let elimCtx := (recTps2ElimCtx info argCtx rs
        (lift (ctxLen indCtx + 1) (ctxLen argCtx) B)) in
      makePi argCtx (
        makePi elimCtx
        (subst
          (TL_cons (liftTermList 0 (ctxLen elimCtx) indices)
            (CtorApp (liftIndInfo 0 (ctxLen argCtx + ctxLen elimCtx) info)
              i
              (makeVarList (ctxLen elimCtx) argCtx)
              (makeVarListStep2 0 elimCtx)
            ))
          (lift (ctxLen indCtx + 1) (ctxLen argCtx + ctxLen elimCtx) B))
      )
  end.

Fixpoint elimFsTypesH (info : IndInfo) (indCtx : Ctx) (i : nat) (ctps : CtorTypeList) B :=
  match ctps with
    | CTL_nil => TL_nil
    | CTL_cons ctps' ctp =>
      TL_cons (elimFsTypesH info indCtx (S i) ctps' B)
      (ctorElimType info indCtx i ctp B)
  end.

Definition elimFsTypes (info : IndInfo) B :=
  match info with
    | MkIndInfo indCtx _ ctps => elimFsTypesH info indCtx 0 ctps B
  end.

Inductive HasTp (ctx : Ctx) : Term -> Term -> Set :=
| HT_convR : forall M T T' , HasTp ctx M T -> rrto T T' -> HasTp ctx M T'
| HT_convL : forall M T T' , HasTp ctx M T -> rrto T' T -> HasTp ctx M T'
| HT_sub : forall M T T' , HasTp ctx M T -> subtype T T' -> HasTp ctx M T'
(* | HT_Prp : forall i , HasTp ctx Prp (Sort i) *)
| HT_Sort : forall i, HasTp ctx (Sort i) (Sort (S i))
| HT_Pi_P : forall i A B ,
  HasTp ctx A (Sort i) ->
  HasTp (Ctx_cons ctx A) B (Sort i) ->
  HasTp ctx (Pi A B) (Sort i)
| HT_Pi_I : forall i A B ,
  HasTp ctx A (Sort i) ->
  HasTp (Ctx_cons ctx A) B (Sort 0) ->
  HasTp ctx (Pi A B) (Sort 0)
| HT_IndType : forall info indices indCtx i ,
  WfIndInfo ctx info indCtx i ->
  HasTpTermList ctx indices indCtx ->
  HasTp ctx (IndType info indices) (Sort i)
| HT_Var : forall i T, isNth_Ctx T i ctx ->
  HasTp ctx (Var i) T
| HT_App : forall A B M N,
  HasTp ctx M (Pi A B) -> HasTp ctx N A ->
  HasTp ctx (App M N) (substOne N B)
| HT_Lam : forall i A M B,
  HasTp ctx A (Sort i) ->
  HasTp (Ctx_cons ctx A) M B ->
  HasTp ctx (Lam A M) (Pi A B)
| HT_CtorApp : forall info indCtx indI argCtx rs indices i args recArgs,
  WfIndInfo ctx info indCtx indI ->
  nthCtorType i info = Some (MkCtorType argCtx rs indices) ->
  HasTpTermList ctx args argCtx ->
  HasTpTermList_TL ctx recArgs (recTps2Types info argCtx rs) ->
  HasTp ctx (CtorApp info i args recArgs)
  (IndType info (substTermList 0 args indices))
| HT_Elim_P : forall info indCtx indI fs params scrut B Bi,
  WfIndInfo ctx info indCtx (S indI) ->
  (HasTp
    (Ctx_cons (Ctx_app ctx indCtx)
      (IndType (liftIndInfo 0 (ctxLen indCtx) info) (makeVarList 0 indCtx)))
    B (Sort Bi)) ->
  HasTpTermList_TL ctx fs (elimFsTypes info B) ->
  HasTpTermList ctx params indCtx ->
  HasTp ctx scrut (IndType info params) ->
  HasTp ctx (Elim info fs params scrut) (subst (TL_cons params scrut) B)
| HT_Elim_I : forall info indCtx fs params scrut B Bi,
  WfIndInfo ctx info indCtx 0 ->
  (HasTp
    (Ctx_cons (Ctx_app ctx indCtx)
      (IndType (liftIndInfo 0 (ctxLen indCtx) info) (makeVarList 0 indCtx)))
    B (Sort Bi)) ->
  ((Bi = 0) + (numCtors info <= 1)) ->
  HasTpTermList_TL ctx fs (elimFsTypes info B) ->
  HasTpTermList ctx params indCtx ->
  HasTp ctx scrut (IndType info params) ->
  HasTp ctx (Elim info fs params scrut) (subst (TL_cons params scrut) B)
(*
| HT_Elim_I0 : forall indCtx params scrut B,
  WfCtx ctx indCtx 0 ->
  HasTpTermList ctx params indCtx ->
  HasTp ctx scrut (IndType (MkIndInfo indCtx 0 CTL_nil) params) ->
  HasTp ctx (Elim (MkIndInfo indCtx 0 CTL_nil) TL_nil params scrut) (subst (TL_cons params scrut) B)
*)

(* FIXME: impredicative elims *)

with HasTpTermList (ctx : Ctx) : TermList -> Ctx -> Set :=
| HT_TL_nil : HasTpTermList ctx TL_nil Ctx_nil
| HT_TL_cons : forall l lCtx M T,
  HasTpTermList ctx l lCtx -> HasTp ctx M (subst l T) ->
  HasTpTermList ctx (TL_cons l M) (Ctx_cons lCtx T)

(* same as above, but with no substitution, since the types are not a
 * Ctx, and so are not dependent *)
with HasTpTermList_TL (ctx : Ctx) : TermList -> TermList -> Set :=
| HT_TL_nil_TL : HasTpTermList_TL ctx TL_nil TL_nil
| HT_TL_cons_TL : forall l Ts M T,
  HasTpTermList_TL ctx l Ts -> HasTp ctx M T ->
  HasTpTermList_TL ctx (TL_cons l M) (TL_cons Ts T)

(* states that a Ctx is well-formed with max sort i *)
with WfCtx (ctx : Ctx) : Ctx -> nat -> Set :=
| WF_Ctx_nil : forall i, WfCtx ctx Ctx_nil i
| WF_Ctx_cons : forall ctx' A i,
  WfCtx ctx ctx' i -> HasTp ctx A (Sort i) -> WfCtx ctx (Ctx_cons ctx' A) i

with WfIndInfo (ctx : Ctx) : IndInfo -> Ctx -> nat -> Set :=
| WF_MkIndInfo : forall indCtx i ctps,
  WfCtx ctx indCtx i ->
  WfCtorTypeList ctx indCtx ctps i ->
  WfIndInfo ctx (MkIndInfo indCtx i ctps) indCtx i

with WfCtorTypeList (ctx : Ctx) : Ctx -> CtorTypeList -> nat -> Set :=
| WF_CTL_nil : forall indCtx i, WfCtorTypeList ctx indCtx CTL_nil i
| WF_CTL_cons : forall indCtx i ctps ctp,
  WfCtorTypeList ctx indCtx ctps i ->
  WfCtorType ctx indCtx ctp i ->
  WfCtorTypeList ctx indCtx (CTL_cons ctps ctp) i

with WfCtorType (ctx : Ctx) : Ctx -> CtorType -> nat -> Set :=
| WF_MkCtorType : forall indCtx argCtx i r indices,
  WfCtx ctx argCtx i ->
  WfRecTpList ctx indCtx argCtx r i ->
  HasTpTermList (Ctx_app ctx argCtx) indices indCtx ->
  WfCtorType ctx indCtx (MkCtorType argCtx r indices) i

with WfRecTpList (ctx : Ctx) : Ctx -> Ctx -> RecTpList -> nat -> Set :=
| WF_RTL_nil : forall indCtx argCtx i, WfRecTpList ctx indCtx argCtx RTL_nil i
| WF_RTL_cons : forall indCtx argCtx i rs r,
  WfRecTpList ctx indCtx argCtx rs i ->
  WfRecTp ctx indCtx argCtx r i ->
  WfRecTpList ctx indCtx argCtx (RTL_cons rs r) i

with WfRecTp (ctx : Ctx) : Ctx -> Ctx -> RecTp -> nat -> Set :=
| WF_MkRecTp : forall indCtx argCtx i recCtx recIndices,
  WfCtx (Ctx_app ctx argCtx) recCtx i ->
  HasTpTermList (Ctx_app ctx argCtx) recIndices indCtx ->
  WfRecTp ctx indCtx argCtx (MkRecTp recCtx recIndices) i
.


Require Export CommonDefinitions Point.NatPointCore2D.

(** We implement the brute force algorithm as a sanity check *)
Fixpoint n2_brute_force (pts : list point) : option nat
  := match pts with
       | nil => None
       | pt::pts' => fold_left option_min
                               (map (fun pt' => Some ∥ pt' -- pt ∥²)
                                    pts')
                               (n2_brute_force pts')
     end.


(*
 D_diamond (D<>)
 T ::= Bot | Top | p.Type | { Type: S..U } | (z: T) -> T^z | T1 /\ T2 | T1 \/ T2
 t ::= p | t t
 p ::= x | v
 v ::= { Type = T } | lambda x:T.t
*)

(* based on *)
(***************************************************************************
* Preservation and Progress for System-F with Subtyping - Definitions      *
* Brian Aydemir & Arthur Charguéraud, March 2007                           *
***************************************************************************)

Set Implicit Arguments.
Require Import LibLN.
Implicit Types x : var.

(* ********************************************************************** *)
(** * Description of the Language *)

(** Representation of pre-types *)

Inductive typ : Set :=
  | typ_bot   : typ
  | typ_top   : typ
  | typ_and   : typ -> typ -> typ
  | typ_or    : typ -> typ -> typ
  | typ_sel  : trm -> typ
  | typ_mem   : typ -> typ -> typ
  | typ_all   : typ -> typ -> typ

(** Representation of pre-terms *)

with trm : Set :=
  | trm_bvar : nat -> trm
  | trm_fvar : var -> trm
  | trm_abs  : typ -> trm -> trm
  | trm_mem  : typ -> trm
  | trm_app  : trm -> trm -> trm.

Fixpoint open_t_rec (k : nat) (f : trm) (T : typ) {struct T} : typ :=
  match T with
  | typ_bot         => typ_bot
  | typ_top         => typ_top
  | typ_and T1 T2   => typ_and (open_t_rec k f T1) (open_t_rec k f T2)
  | typ_or  T1 T2   => typ_or  (open_t_rec k f T1) (open_t_rec k f T2)
  | typ_sel t       => typ_sel (open_e_rec k f t)
  | typ_mem T1 T2   => typ_mem (open_t_rec k f T1) (open_t_rec k f T2)
  | typ_all T1 T2   => typ_all (open_t_rec k f T1) (open_t_rec (S k) f T2)
  end

(** Opening up a term binder occuring in a term *)

with open_e_rec (k : nat) (f : trm) (e : trm) {struct e} : trm :=
  match e with
  | trm_bvar i    => If k = i then f else (trm_bvar i)
  | trm_fvar x    => trm_fvar x
  | trm_abs V e1  => trm_abs (open_t_rec k f V) (open_e_rec (S k) f e1)
  | trm_mem T     => trm_mem (open_t_rec k f T)
  | trm_app e1 e2 => trm_app (open_e_rec k f e1) (open_e_rec k f e2)
  end.

Definition open_t T f := open_t_rec 0 f T.
Definition open_e t u := open_e_rec 0 u t.

(** Notation for opening up binders with variables *)

Notation "t 'open_t_var' x" := (open_t t (trm_fvar x)) (at level 67).
Notation "t 'open_e_var' x" := (open_e t (trm_fvar x)) (at level 67).

(** Types as locally closed pre-types *)

Inductive type : typ -> Prop :=
  | type_bot :
      type typ_bot
  | type_top :
      type typ_top
  | type_and : forall T1 T2,
      type T1 ->
      type T2 ->
      type (typ_and T1 T2)
  | type_or  : forall T1 T2,
      type T1 ->
      type T2 ->
      type (typ_or  T1 T2)
  | type_sel : forall e1,
      term e1 ->
      type (typ_sel e1)
  | type_mem : forall T1 T2,
      type T1 ->
      type T2 ->
      type (typ_mem T1 T2)
  | type_all : forall L T1 T2,
      type T1 ->
      (forall x, x \notin L -> type (T2 open_t_var x)) ->
      type (typ_all T1 T2)

(** Terms as locally closed pre-terms *)

with term : trm -> Prop :=
  | term_var : forall x,
      term (trm_fvar x)
  | term_abs : forall L V e1,
      type V ->
      (forall x, x \notin L -> term (e1 open_e_var x)) ->
      term (trm_abs V e1)
  | term_mem : forall T1,
      type T1 ->
      term (trm_mem T1)
  | term_app : forall e1 e2,
      term e1 ->
      term e2 ->
      term (trm_app e1 e2).

(** Values *)

Inductive value : trm -> Prop :=
  | value_abs  : forall V e1, term (trm_abs V e1) ->
                 value (trm_abs V e1)
  | value_mem : forall V, term (trm_mem V) ->
                 value (trm_mem V).

(** Environment is an associative list of bindings. *)

Definition env := LibEnv.env typ.

(** Well-formedness of a pre-type T in an environment E:
  all the type variables of T must be bound via a
  subtyping relation in E. This predicates implies
  that T is a type *)

Inductive wft : env -> typ -> Prop :=
  | wft_bot : forall E,
      wft E typ_bot
  | wft_top : forall E,
      wft E typ_top
  | wft_and : forall E T1 T2,
      wft E T1 ->
      wft E T2 ->
      wft E (typ_and T1 T2)
  | wft_or  : forall E T1 T2,
      wft E T1 ->
      wft E T2 ->
      wft E (typ_or  T1 T2)
  | wft_sel : forall E e,
      value e \/ (exists x, trm_fvar x = e) ->
      wfe E e ->
      wft E (typ_sel e)
  | wft_mem : forall E T1 T2,
      wft E T1 ->
      wft E T2 ->
      wft E (typ_mem T1 T2)
  | wft_all : forall L E T1 T2,
      wft E T1 ->
      (forall x, x \notin L ->
        wft (E & x ~ T1) (T2 open_t_var x)) ->
      wft E (typ_all T1 T2)
with wfe : env -> trm -> Prop :=
  | wfe_var : forall U E x,
      binds x U E ->
      wfe E (trm_fvar x)
   | wfe_abs : forall L E V e,
      wft E V ->
      (forall x, x \notin L -> wfe (E & x ~ V) (e open_e_var x)) ->
      wfe E (trm_abs V e)
  | wfe_mem : forall E T,
      wft E T ->
      wfe E (trm_mem T)
  | wfe_app : forall E e1 e2,
      wfe E e1 ->
      wfe E e2 ->
      wfe E (trm_app e1 e2)
.

(** A environment E is well-formed if it contains no duplicate bindings
  and if each type in it is well-formed with respect to the environment
  it is pushed on to. *)

Inductive okt : env -> Prop :=
  | okt_empty :
      okt empty
  | okt_push : forall E x T,
      okt E -> wft E T -> x # E -> okt (E & x ~ T).

(** Subtyping relation *)

Inductive sub : env -> typ -> typ -> Prop :=
  | sub_bot : forall E T,
      okt E ->
      wft E T ->
      sub E typ_bot T
  | sub_top : forall E S,
      okt E ->
      wft E S ->
      sub E S typ_top
  | sub_and11 : forall E T1 T2 T,
      wft E T2 ->
      sub E T1 T ->
      sub E (typ_and T1 T2) T
  | sub_and12 : forall E T1 T2 T,
      wft E T1 ->
      sub E T2 T ->
      sub E (typ_and T1 T2) T
  | sub_and2 : forall E T T1 T2,
      sub E T T1 ->
      sub E T T2 ->
      sub E T (typ_and T1 T2)
  | sub_or21 : forall E T T1 T2,
      wft E T2 ->
      sub E T T1 ->
      sub E T (typ_or T1 T2)
  | sub_or22 : forall E T T1 T2,
      wft E T1 ->
      sub E T T2 ->
      sub E T (typ_or T1 T2)
  | sub_or1 : forall E T1 T2 T,
      sub E T1 T->
      sub E T2 T ->
      sub E (typ_or T1 T2) T
  | sub_refl_sel : forall E t,
      okt E ->
      wft E (typ_sel t) ->
      sub E (typ_sel t) (typ_sel t)
  | sub_sel1 : forall E S U t,
      has E t (typ_mem S U) ->
      sub E (typ_sel t) U
  | sub_sel2 : forall E S U t,
      has E t (typ_mem S U) ->
      sub E S (typ_sel t)
  | sub_mem : forall E S1 U1 S2 U2,
      sub E S2 S1 -> sub E U1 U2 ->
      sub E (typ_mem S1 U1) (typ_mem S2 U2)
  | sub_all : forall L E S1 S2 T1 T2,
      sub E T1 S1 ->
      (forall x, x \notin L ->
          sub (E & x ~ T1) (S2 open_t_var x) (T2 open_t_var x)) ->
      sub E (typ_all S1 S2) (typ_all T1 T2)
  | sub_trans : forall E S T U,
      sub E S T ->
      sub E T U ->
      sub E S U

with has : env -> trm -> typ -> Prop :=
  | has_var : forall E x T,
      okt E ->
      binds x T E ->
      has E (trm_fvar x) T
  | has_mem : forall E T,
      okt E -> wft E T ->
      has E (trm_mem T) (typ_mem T T)
  | has_abs : forall E V e T,(* dummy case for smooth substitution lemma, see val_typing_has *)
      okt E -> wfe E (trm_abs V e) -> wft E (typ_all V T) ->
      has E (trm_abs V e) (typ_all V T) (* return typ doesn't matter, as long as it's moot for sel1 and sel2 *)
  | has_sub : forall E t T U,
      has E t T ->
      sub E T U ->
      has E t U
.

(** Typing relation *)

Inductive typing : env -> trm -> typ -> Prop :=
  | typing_var : forall E x T,
      okt E ->
      binds x T E ->
      typing E (trm_fvar x) T
  | typing_abs : forall L E V e1 T1,
      (forall x, x \notin L ->
        typing (E & x ~ V) (e1 open_e_var x) (T1 open_t_var x)) ->
      typing E (trm_abs V e1) (typ_all V T1)
  | typing_mem : forall E T1,
      okt E ->
      wft E T1 ->
      typing E (trm_mem T1) (typ_mem T1 T1)
  | typing_app : forall T1 E e1 e2 T2,
      typing E e1 (typ_all T1 T2) ->
      typing E e2 T1 ->
      wft E T2 ->
      typing E (trm_app e1 e2) T2
  | typing_appvar : forall T1 E e1 e2 T2 T2' M,
      typing E e1 (typ_all T1 T2) ->
      typing E e2 T1 ->
      has E e2 M ->
      T2' = open_t T2 e2 ->
      wft E T2' ->
      typing E (trm_app e1 e2) T2'
  | typing_sub : forall S E e T,
      typing E e S ->
      sub E S T ->
      typing E e T.

(** One-step reduction *)

Inductive red : trm -> trm -> Prop :=
  | red_app_1 : forall e1 e1' e2,
      term e2 ->
      red e1 e1' ->
      red (trm_app e1 e2) (trm_app e1' e2)
  | red_app_2 : forall e1 e2 e2',
      value e1 ->
      red e2 e2' ->
      red (trm_app e1 e2) (trm_app e1 e2')
  | red_abs : forall V e1 v2,
      term (trm_abs V e1) ->
      value v2 ->
      red (trm_app (trm_abs V e1) v2) (open_e e1 v2).

(** Our goal is to prove preservation and progress *)

Definition preservation := forall e e' T,
  typing empty e T ->
  red e e' ->
  typing empty e' T.

Definition progress := forall e T,
  typing empty e T ->
     value e
  \/ exists e', red e e'.

(***************************************************************************
* Preservation and Progress for System-F with Subtyping - Infrastructure   *
***************************************************************************)

(* ********************************************************************** *)
(** * Additional Definitions Used in the Proofs *)

(** Computing free variables in a type *)

Fixpoint fv_t (T : typ) {struct T} : vars :=
  match T with
  | typ_bot         => \{}
  | typ_top         => \{}
  | typ_and T1 T2   => (fv_t T1) \u (fv_t T2)
  | typ_or  T1 T2   => (fv_t T1) \u (fv_t T2)
  | typ_sel t       => fv_e t
  | typ_mem T1 T2   => (fv_t T1) \u (fv_t T2)
  | typ_all T1 T2   => (fv_t T1) \u (fv_t T2)
  end

(** Computing free variables in a term *)

with fv_e (e : trm) {struct e} : vars :=
  match e with
  | trm_bvar i    => \{}
  | trm_fvar x    => \{x}
  | trm_abs V e1  => (fv_t V) \u (fv_e e1)
  | trm_mem T     => fv_t T
  | trm_app e1 e2 => (fv_e e1) \u (fv_e e2)
  end.

(** Substitution for free type variables in types. *)

Fixpoint subst_t (z : var) (u : trm) (T : typ) {struct T} : typ :=
  match T with
  | typ_bot         => typ_bot
  | typ_top         => typ_top
  | typ_and T1 T2   => typ_and (subst_t z u T1) (subst_t z u T2)
  | typ_or  T1 T2   => typ_or  (subst_t z u T1) (subst_t z u T2)
  | typ_sel t       => typ_sel (subst_e z u t)
  | typ_mem T1 T2   => typ_mem (subst_t z u T1) (subst_t z u T2)
  | typ_all T1 T2   => typ_all (subst_t z u T1) (subst_t z u T2)
  end

(** Substitution for free term variables in terms. *)

with subst_e (z : var) (u : trm) (e : trm) {struct e} : trm :=
  match e with
  | trm_bvar i    => trm_bvar i
  | trm_fvar x    => If x = z then u else (trm_fvar x)
  | trm_abs V e1  => trm_abs (subst_t z u V) (subst_e z u e1)
  | trm_mem T1    => trm_mem (subst_t z u T1)
  | trm_app e1 e2 => trm_app (subst_e z u e1) (subst_e z u e2)
  end.

(* ********************************************************************** *)
(** * Tactics *)

(** Constructors as hints. *)

Hint Constructors type term wft wfe ok okt value red.

Hint Resolve
  sub_bot sub_top sub_refl_sel
  typing_var typing_app typing_sub.

(** Gathering free names already used in the proofs *)

Ltac gather_vars :=
  let A := gather_vars_with (fun x : vars => x) in
  let B := gather_vars_with (fun x : var => \{x}) in
  let C := gather_vars_with (fun x : typ => fv_t x) in
  let D := gather_vars_with (fun x : trm => fv_e x) in
  let E := gather_vars_with (fun x : env => dom x) in
  constr:(A \u B \u C \u D \u E).

(** "pick_fresh x" tactic create a fresh variable with name x *)

Ltac pick_fresh x :=
  let L := gather_vars in (pick_fresh_gen L x).

(** "apply_fresh T as x" is used to apply inductive rule which
   use an universal quantification over a cofinite set *)

Tactic Notation "apply_fresh" constr(T) "as" ident(x) :=
  apply_fresh_base T gather_vars x.

Tactic Notation "apply_fresh" "*" constr(T) "as" ident(x) :=
  apply_fresh T as x; auto*.

(** These tactics help applying a lemma which conclusion mentions
  an environment (E & F) in the particular case when F is empty *)

Ltac get_env :=
  match goal with
  | |- wft ?E _ => E
  | |- wfe ?E _ => E
  | |- sub ?E _ _  => E
  | |- has ?E _ _ => E
  | |- typing ?E _ _ => E
  end.

Tactic Notation "apply_empty_bis" tactic(get_env) constr(lemma) :=
  let E := get_env in rewrite <- (concat_empty_r E);
  eapply lemma; try rewrite concat_empty_r.

Tactic Notation "apply_empty" constr(F) :=
  apply_empty_bis (get_env) F.

Tactic Notation "apply_empty" "*" constr(F) :=
  apply_empty F; auto*.

Scheme typ_mut := Induction for typ Sort Prop
with   trm_mut := Induction for trm Sort Prop.
Combined Scheme typ_trm_mutind from typ_mut, trm_mut.

Scheme type_mut := Induction for type Sort Prop
with term_mut := Induction for term Sort Prop.
Combined Scheme lc_mutind from type_mut, term_mut.

Scheme wft_mut := Induction for wft Sort Prop
with wfe_mut := Induction for wfe Sort Prop.
Combined Scheme wf_mutind from wft_mut, wfe_mut.

Scheme sub_mut := Induction for sub Sort Prop
with has_mut := Induction for has Sort Prop.
Combined Scheme sub_has_mutind from sub_mut, has_mut.

(* ********************************************************************** *)
(** * Properties of Substitutions *)

(** Substitution on indices is identity on well-formed terms. *)

Lemma open_rec_lc_core : (forall T j v u i, i <> j ->
  (open_t_rec j v T) = open_t_rec i u (open_t_rec j v T) ->
  T = open_t_rec i u T) /\ (forall e j v u i, i <> j ->
  open_e_rec j v e = open_e_rec i u (open_e_rec j v e) ->
  e = open_e_rec i u e).
Proof.
  apply typ_trm_mutind;
  try (introv IH1 IH2 Neq H);
  try (introv IH Neq H);
  try (introv Neq H);
  simpl in *; inversion H; f_equal*.
  case_nat*. case_nat*.
Qed.

Lemma open_rec_lc : (forall T,
  type T -> forall u k, T = open_t_rec k u T) /\ (forall e,
  term e -> forall u k, e = open_e_rec k u e).
Proof.
  apply lc_mutind; intros; simpl; f_equal*.
  pick_fresh x. apply* ((proj1 open_rec_lc_core) T2 0 (trm_fvar x)).
  pick_fresh x. apply* ((proj2 open_rec_lc_core) e1 0 (trm_fvar x)).
Qed.

Lemma open_t_var_type : forall x T,
  type T -> T open_t_var x = T.
Proof.
  intros. unfold open_t. rewrite* <- (proj1 open_rec_lc).
Qed.

(** Substitution for a fresh name is identity. *)

Lemma subst_fresh : (forall T z u,
  z \notin fv_t T -> subst_t z u T = T) /\ (forall e z u,
  z \notin fv_e e -> subst_e z u e = e).
Proof.
  apply typ_trm_mutind; simpl; intros; f_equal*.
  case_var*.
Qed.

(** Substitution distributes on the open operation. *)

Lemma subst_open_rec : (forall T1 t2 x u n, term u ->
  subst_t x u (open_t_rec n t2 T1) =
  open_t_rec n (subst_e x u t2) (subst_t x u T1)) /\ (forall t1 t2 x u n, term u ->
  subst_e x u (open_e_rec n t2 t1) =
  open_e_rec n (subst_e x u t2) (subst_e x u t1)).
Proof.
  apply typ_trm_mutind; intros; simpls; f_equal*.
  case_nat*.
  case_var*. rewrite* <- (proj2 open_rec_lc).
Qed.

Lemma subst_t_open_t : forall T1 t2 x u, term u ->
  subst_t x u (open_t T1 t2) =
  open_t (subst_t x u T1) (subst_e x u t2).
Proof.
  unfold open_t. auto* (proj1 subst_open_rec).
Qed.

Lemma subst_e_open_e : forall t1 t2 x u, term u ->
  subst_e x u (open_e t1 t2) =
  open_e (subst_e x u t1) (subst_e x u t2).
Proof.
  unfold open_e. auto* (proj2 subst_open_rec).
Qed.

(** Substitution and open_var for distinct names commute. *)

Lemma subst_t_open_t_var : forall x y u T, y <> x -> term u ->
  (subst_t x u T) open_t_var y = subst_t x u (T open_t_var y).
Proof.
  introv Neq Wu. rewrite* subst_t_open_t.
  simpl. case_var*.
Qed.

Lemma subst_e_open_e_var : forall x y u e, y <> x -> term u ->
  (subst_e x u e) open_e_var y = subst_e x u (e open_e_var y).
Proof.
  introv Neq Wu. rewrite* subst_e_open_e.
  simpl. case_var*.
Qed.

(** Opening up a body t with a type u is the same as opening
  up the abstraction with a fresh name x and then substituting u for x. *)

Lemma subst_t_intro : forall x T2 u,
  x \notin fv_t T2 -> term u ->
  open_t T2 u = subst_t x u (T2 open_t_var x).
Proof.
  introv Fr Wu. rewrite* subst_t_open_t.
  rewrite* (proj1 subst_fresh). simpl. case_var*.
Qed.

Lemma subst_e_intro : forall x t2 u,
  x \notin fv_e t2 -> term u ->
  open_e t2 u = subst_e x u (t2 open_e_var x).
Proof.
  introv Fr Wu. rewrite* subst_e_open_e.
  rewrite* (proj2 subst_fresh). simpl. case_var*.
Qed.

(** Substitutions preserve local closure. *)

Lemma subst_lc :
  (forall T, type T -> forall z u, term u -> type (subst_t z u T)) /\
  (forall e, term e -> forall z u, term u -> term (subst_e z u e)).
Proof.
  apply lc_mutind; intros; simpl; auto.
  apply_fresh* type_all as X. rewrite* subst_t_open_t_var.
  case_var*.
  apply_fresh* term_abs as y. rewrite* subst_e_open_e_var.
Qed.

Lemma subst_t_type : forall T z u,
  type T -> term u -> type (subst_t z u T).
Proof.
  intros. apply* (proj1 subst_lc).
Qed.

Lemma subst_e_term : forall e1 z e2,
  term e1 -> term e2 -> term (subst_e z e2 e1).
Proof.
  intros. apply* (proj2 subst_lc).
Qed.

Lemma subst_e_value : forall e1 z e2,
  value e1 ->  term e2 -> value (subst_e z e2 e1).
Proof.
  intros. inversion H; subst; simpl.
  - apply value_abs.
    assert (trm_abs (subst_t z e2 V) (subst_e z e2 e0) = subst_e z e2 (trm_abs V e0)) as A. {
      simpl. reflexivity.
    }
    rewrite A. apply* subst_e_term.
  - apply value_mem.
    assert (trm_mem (subst_t z e2 V) = subst_e z e2 (trm_mem V)) as A. {
      simpl. reflexivity.
    }
    rewrite A. apply* subst_e_term.
Qed.

Lemma value_is_term: forall e, value e -> term e.
Proof.
  introv H. inversion H; subst; eauto.
Qed.

Hint Resolve subst_t_type subst_e_term subst_e_value value_is_term.

(* ********************************************************************** *)
(** * Properties of well-formedness of a type in an environment *)

(** If a type is well-formed in an environment then it is locally closed. *)

Lemma wf_lc : (forall E T, wft E T -> type T) /\
              (forall E e, wfe E e -> term e).
Proof.
  apply wf_mutind; eauto.
Qed.

Lemma wft_type : forall E T,
  wft E T -> type T.
Proof.
  intros. eapply (proj1 wf_lc); eauto.
Qed.

Lemma wfe_term : forall E e,
  wfe E e -> term e.
Proof.
  intros. eapply (proj2 wf_lc); eauto.
Qed.

(** Through weakening *)

Lemma wf_weaken :
  (forall E0 T, wft E0 T ->
   forall E F G, E0 = E & G ->
                 ok (E & F & G) ->
                 wft (E & F & G) T)
    /\
  (forall E0 e, wfe E0 e ->
   forall E F G, E0 = E & G ->
                 ok (E & F & G) ->
                 wfe (E & F & G) e).
Proof.
  apply wf_mutind; intros; subst; eauto.
  apply_fresh* wft_all as Y. apply_ih_bind* H0.
  apply (@wfe_var U). apply* binds_weaken.
  apply_fresh* wfe_abs as y. apply_ih_bind* H0.
Qed.

Lemma wft_weaken : forall G T E F,
  wft (E & G) T ->
  ok (E & F & G) ->
  wft (E & F & G) T.
Proof.
  intros. eapply (proj1 wf_weaken); eauto.
Qed.

Lemma wft_weaken_empty : forall T E,
  wft empty T ->
  ok E ->
  wft E T.
Proof.
  intros.
  assert (E = empty & E & empty) as A. {
    rewrite concat_empty_l. rewrite concat_empty_r. reflexivity.
  }
  rewrite A. apply wft_weaken.
  rewrite concat_empty_l. auto.
  rewrite concat_empty_l. rewrite concat_empty_r. auto.
Qed.

Lemma wfe_weaken : forall G T E F,
  wfe (E & G) T ->
  ok (E & F & G) ->
  wfe (E & F & G) T.
Proof.
  intros. eapply (proj2 wf_weaken); eauto.
Qed.

Lemma wfe_weaken_empty : forall T E,
  wfe empty T ->
  ok E ->
  wfe E T.
Proof.
  intros.
  assert (E = empty & E & empty) as A. {
    rewrite concat_empty_l. rewrite concat_empty_r. reflexivity.
  }
  rewrite A. apply wfe_weaken.
  rewrite concat_empty_l. auto.
  rewrite concat_empty_l. rewrite concat_empty_r. auto.
Qed.

(** Through narrowing *)

Lemma wf_narrow : (forall E0 T, wft E0 T -> forall V F U E x,
  E0 = (E & x ~ V & F) ->
  ok (E & x ~ U & F) ->
  wft (E & x ~ U & F) T)
  /\
(forall E0 e, wfe E0 e -> forall V F U E x,
  E0 = (E & x ~ V & F) ->
  ok (E & x ~ U & F) ->
  wfe (E & x ~ U & F) e).
Proof.
  apply wf_mutind; intros; subst; eauto.
  apply_fresh* wft_all as Y. apply_ih_bind* H0.
  destruct (binds_middle_inv b) as [K|[K|K]]; try destructs K.
    applys wfe_var. apply* binds_concat_right.
    subst. applys wfe_var. apply~ binds_middle_eq.
    applys wfe_var. apply~ binds_concat_left.
     apply* binds_concat_left.
  apply_fresh* wfe_abs as y. apply_ih_bind* H0.
Qed.

Lemma wft_narrow : forall V F U T E x,
  wft (E & x ~ V & F) T ->
  ok (E & x ~ U & F) ->
  wft (E & x ~ U & F) T.
Proof.
  intros. eapply (proj1 wf_narrow); eauto.
Qed.

(** Through substitution *)

Lemma wf_subst : (forall E0 T, wft E0 T -> forall F Q E Z u,
  E0 = E & Z ~ Q & F ->
  (value u \/ exists x, trm_fvar x = u) -> wfe E u ->
  ok (E & map (subst_t Z u) F) ->
  wft (E & map (subst_t Z u) F) (subst_t Z u T)) /\
  (forall E0 e, wfe E0 e -> forall F Q E Z u,
  E0 = E & Z ~ Q & F ->
  (value u \/ exists x, trm_fvar x = u) -> wfe E u ->
  ok (E & map (subst_t Z u) F) ->
  wfe (E & map (subst_t Z u) F) (subst_e Z u e)).
Proof.
  apply wf_mutind; intros; subst; simpl; eauto.
  - destruct o as [? | [? ?]].
    + apply* wft_sel. left. apply subst_e_value. assumption. apply* wfe_term.
    + subst. simpl. case_var*.
      * apply_empty* wft_weaken.
      * apply* wft_sel. rewrite* <- ((proj2 subst_fresh) (trm_fvar x) Z u).
        simpl. auto.
  - apply_fresh* wft_all as Y.
    lets: wft_type.
    rewrite* subst_t_open_t_var.
    apply_ih_map_bind* H0. apply* wfe_term.
  - case_var*.
    + apply_empty* (proj2 wf_weaken).
    + destruct (binds_concat_inv b) as [?|[? ?]].
      apply (@wfe_var (subst_t Z u U)).
       apply~ binds_concat_right.
      destruct (binds_push_inv H3) as [[? ?]|[? ?]].
        subst. false~.
        applys wfe_var. apply* binds_concat_left.
  - apply_fresh* wfe_abs as y.
    lets: (proj2 wf_lc).
    rewrite* subst_e_open_e_var.
    apply_ih_map_bind* H0.
Qed.

Lemma wft_subst : forall F Q E Z u T,
  wft (E & Z ~ Q & F) T ->
  (value u \/ exists x, trm_fvar x = u) -> wfe E u ->
  ok (E & map (subst_t Z u) F) ->
  wft (E & map (subst_t Z u) F) (subst_t Z u T).
Proof.
  intros. eapply (proj1 wf_subst); eauto.
Qed.

Lemma wft_subst1 : forall F Q Z u T,
  wft (Z ~ Q & F) T ->
  (value u \/ exists x, trm_fvar x = u) -> wfe empty u ->
  ok (map (subst_t Z u) F) ->
  wft (map (subst_t Z u) F) (subst_t Z u T).
Proof.
  intros.
  rewrite <- (@concat_empty_l typ (map (subst_t Z u) F)).
  apply* wft_subst.
  rewrite concat_empty_l. eassumption.
  rewrite concat_empty_l. eassumption.
Qed.

Lemma wft_subst_empty : forall Q Z u T,
  wft (Z ~ Q) T ->
  (value u \/ exists x, trm_fvar x = u) -> wfe empty u ->
  wft empty (subst_t Z u T).
Proof.
  intros.
  assert (empty & map (subst_t Z u) empty = empty) as A. {
    rewrite map_empty. rewrite concat_empty_l. reflexivity.
  }
  rewrite <- A. eapply wft_subst; eauto.
  rewrite concat_empty_l. rewrite concat_empty_r. eauto.
  rewrite A. eauto.
Qed.

(** Through type reduction *)

Lemma wft_open : forall E u T1 T2,
  ok E ->
  wft E (typ_all T1 T2) ->
  (value u \/ exists x, trm_fvar x = u) -> wfe E u ->
  wft E (open_t T2 u).
Proof.
  introv Ok WA VU WU. inversions WA. pick_fresh X.
  auto* wft_type. rewrite* (@subst_t_intro X).
  lets K: (@wft_subst empty).
  specializes_vars K. clean_empty K. apply* K.
  apply* wfe_term.
Qed.

(* ********************************************************************** *)
(** * Relations between well-formed environment and types well-formed
  in environments *)

(** If an environment is well-formed, then it does not contain duplicated keys. *)

Lemma ok_from_okt : forall E,
  okt E -> ok E.
Proof.
  induction 1; auto.
Qed.

Hint Extern 1 (ok _) => apply ok_from_okt.

(** Extraction from an assumption in a well-formed environments *)

Lemma wft_from_env_has : forall x U E,
  okt E -> binds x U E -> wft E U.
Proof.
  induction E using env_ind; intros Ok B.
  false* binds_empty_inv.
  inversions Ok.
    false (empty_push_inv H0).
    destruct (eq_push_inv H) as [? [? ?]]. subst. clear H.
     destruct (binds_push_inv B) as [[? ?]|[? ?]]. subst.
       apply_empty* wft_weaken.
       apply_empty* wft_weaken.
Qed.

(** Extraction from a well-formed environment *)

Lemma wft_from_okt : forall x T E,
  okt (E & x ~ T) -> wft E T.
Proof.
  intros. inversions* H.
  false (empty_push_inv H1).
  destruct (eq_push_inv H0) as [? [? ?]]. subst. assumption.
Qed.

(** Automation *)

Lemma wft_weaken_right : forall T E F,
  wft E T ->
  ok (E & F) ->
  wft (E & F) T.
Proof.
  intros. apply_empty* wft_weaken.
Qed.

Hint Resolve wft_weaken_right.
Hint Resolve wft_from_okt.
Hint Immediate wft_from_env_has.
Hint Resolve wft_subst.

(* ********************************************************************** *)
(** ** Properties of well-formedness of an environment *)

(** Inversion lemma *)

Lemma okt_push_inv : forall E x T,
  okt (E & x ~ T) -> okt E /\ wft E T /\ x # E.
Proof.
  introv O. inverts O.
    false* empty_push_inv.
    lets (?&M&?): (eq_push_inv H). subst. eauto.
Qed.

Lemma okt_push_type : forall E x T,
  okt (E & x ~ T) -> type T.
Proof. intros. applys wft_type. forwards*: okt_push_inv. Qed.

Hint Immediate okt_push_type.

(** Through narrowing *)

Lemma okt_narrow : forall V (E F:env) U x,
  okt (E & x ~ V & F) ->
  wft E U ->
  okt (E & x ~ U & F).
Proof.
  introv O W. induction F using env_ind.
  rewrite concat_empty_r in *. lets*: (okt_push_inv O).
  rewrite concat_assoc in *.
  lets (?&?&?): (okt_push_inv O).
  applys~ okt_push. applys* wft_narrow.
Qed.

(** Through substitution *)

Lemma okt_subst : forall Q Z u (E F:env),
  okt (E & Z ~ Q & F) ->
  (value u \/ exists x, trm_fvar x = u) -> wfe E u ->
  okt (E & map (subst_t Z u) F).
Proof.
 introv O V W. induction F using env_ind.
  rewrite map_empty. rewrite concat_empty_r in *.
   lets*: (okt_push_inv O).
  rewrite map_push. rewrite concat_assoc in *.
   lets*: (okt_push_inv O).
   apply okt_push. apply* IHF. apply* wft_subst. auto*.
Qed.

Lemma okt_subst1 : forall Q Z u (F:env),
  okt (Z ~ Q & F) ->
  (value u \/ exists x, trm_fvar x = u) -> wfe empty u ->
  okt (map (subst_t Z u) F).
Proof.
  intros.
  rewrite <- concat_empty_l. apply* okt_subst.
  rewrite concat_empty_l. eassumption.
Qed.

(** Automation *)

Hint Resolve okt_narrow okt_subst wft_weaken.

(* ********************************************************************** *)
(** ** Environment is unchanged by substitution from a fresh name *)

Ltac destruct_notin_union :=
  match goal with
    | H: _ \notin _ \u _ |- _ => eapply notin_union in H; destruct H
  end.

Lemma notin_fv_open_rec : (forall T k y x,
  x \notin fv_t (open_t_rec k (trm_fvar y) T) ->
  x \notin fv_t T) /\ (forall e k y x,
  x \notin fv_e (open_e_rec k (trm_fvar y) e) ->
  x \notin fv_e e).
Proof.
  apply typ_trm_mutind; simpl; intros;
  repeat destruct_notin_union; eauto using notin_union_l.
Qed.

Lemma notin_fv_t_open : forall y x T,
  x \notin fv_t (T open_t_var y) ->
  x \notin fv_t T.
Proof.
  unfold open_t. intros. apply* (proj1 notin_fv_open_rec).
Qed.

Lemma notin_fv_e_open : forall y x e,
  x \notin fv_e (e open_e_var y) ->
  x \notin fv_e e.
Proof.
  unfold open_e. intros. apply* (proj2 notin_fv_open_rec).
Qed.

Lemma notin_fv_wf_rec :
  (forall E T,
     wft E T -> forall x, x # E -> x \notin fv_t T) /\
  (forall E e,
     wfe E e -> forall x, x # E -> x \notin fv_e e).
Proof.
  apply wf_mutind; intros; simpl; eauto.
  notin_simpl; auto. pick_fresh Y. apply* (@notin_fv_t_open Y).
  rewrite notin_singleton. intro. subst. applys binds_fresh_inv b H.
  notin_simpl; auto. pick_fresh y. apply* (@notin_fv_e_open y).
Qed.

Lemma notin_fv_wf : forall E x T,
  wft E T -> x # E -> x \notin fv_t T.
Proof.
  intros. eapply (proj1 notin_fv_wf_rec); eauto.
Qed.

Lemma map_subst_id : forall G z u,
  okt G -> z # G -> G = map (subst_t z u) G.
Proof.
  induction 1; intros Fr; autorewrite with rew_env_map; simpl.
  auto.
  rewrite* <- IHokt. rewrite* (proj1 subst_fresh). apply* notin_fv_wf.
Qed.

(* ********************************************************************** *)
(** ** Regularity of relations *)

(** The subtyping relation is restricted to well-formed objects. *)

Lemma sub_has_regular : (forall E S T,
  sub E S T -> okt E /\ wft E S /\ wft E T) /\ (forall E p T,
  has E p T -> okt E /\ wft E (typ_sel p) /\ wft E T).
Proof.
  apply sub_has_mutind; intros; try auto*.
  splits*. destruct H as [? [? A]]. inversion A; subst. assumption.
  splits*. destruct H as [? [? A]]. inversion A; subst. assumption.
  split. auto*. split;
   apply_fresh* wft_all as Y;
    forwards~: (H0 Y); apply_empty* (@wft_narrow T1).
  splits*. apply wft_sel. left. apply value_mem. apply* wfe_term. apply* wfe_mem.
  splits*. apply wft_sel. left. apply value_abs. apply* wfe_term. assumption.
Qed.

Lemma sub_regular : forall E S T,
  sub E S T -> okt E /\ wft E S /\ wft E T.
Proof.
  intros. apply* (proj1 sub_has_regular).
Qed.

Lemma has_regular : forall E p T,
  has E p T -> okt E /\ wft E (typ_sel p) /\ wft E T.
Proof.
  intros. apply* (proj2 sub_has_regular).
Qed.

Lemma has_regular_e : forall E p T,
  has E p T -> (value p \/ (exists x, trm_fvar x = p)) /\ wfe E p.
Proof.
  intros. apply has_regular in H. destruct H as [? [A ?]].
  inversion A; subst. split; assumption.
Qed.

(** The typing relation is restricted to well-formed objects. *)

Lemma typing_regular : forall E e T,
  typing E e T -> okt E /\ wfe E e /\ wft E T.
Proof.
  induction 1.
  splits*.
  splits.
   pick_fresh y. specializes H0 y. destructs~ H0.
    forwards*: okt_push_inv.
   apply_fresh* wfe_abs as y.
     pick_fresh y. forwards~ K: (H0 y). destructs K.
       forwards*: okt_push_inv.
     forwards~ K: (H0 y). destructs K. auto.
   apply_fresh* wft_all as Y.
     pick_fresh y. forwards~ K: (H0 y). destructs K.
      forwards*: okt_push_inv.
     forwards~ K: (H0 Y). destructs K.
      forwards*: okt_push_inv.
  splits*.
  splits*.
  splits*.
  splits*. destructs~ (sub_regular H0).
Qed.

(** The value relation is restricted to well-formed objects. *)

Lemma value_regular : forall t,
  value t -> term t.
Proof.
  induction 1; auto*.
Qed.

(** The reduction relation is restricted to well-formed objects. *)

Lemma red_regular : forall t t',
  red t t' -> term t /\ term t'.
Proof.
  induction 1; split; auto* value_regular.
  inversions H. pick_fresh y. rewrite* (@subst_e_intro y).
Qed.

(** Automation *)

Hint Extern 1 (okt ?E) =>
  match goal with
  | H: sub _ _ _ |- _ => apply (proj31 (sub_regular H))
  | H: has _ _ _ |- _ => apply (proj31 (has_regular H))
  | H: typing _ _ _ |- _ => apply (proj31 (typing_regular H))
  end.

Hint Extern 1 (wft ?E ?T) =>
  match goal with
  | H: typing E _ T |- _ => apply (proj33 (typing_regular H))
  | H: sub E T _ |- _ => apply (proj32 (sub_regular H))
  | H: sub E _ T |- _ => apply (proj33 (sub_regular H))
  | H: has E _ T |- _ => apply (proj33 (has_regular H))
  end.

Hint Extern 1 (wfe ?E ?e) =>
  match goal with
  | H: typing E e _ |- _ => apply (proj32 (typing_regular H))
  | H: has E e _ |- _ => apply (proj2 (has_regular_e H))
  end.

Hint Extern 1 (type ?T) =>
  let go E := apply (@wft_type E); auto in
  match goal with
  | H: typing ?E _ T |- _ => go E
  | H: sub ?E T _ |- _ => go E
  | H: sub ?E _ T |- _ => go E
  end.

Hint Extern 1 (term ?e) =>
  match goal with
  | H: typing _ ?e _ |- _ => apply (wfe_term (proj32 (typing_regular H)))
  | H: red ?e _ |- _ => apply (proj1 (red_regular H))
  | H: red _ ?e |- _ => apply (proj2 (red_regular H))
  end.

(***************************************************************************
* Preservation and Progress for System-F with Subtyping - Proofs           *
***************************************************************************)

(** In parentheses are given the label of the corresponding
  lemma in the description of the POPLMark Challenge. *)

(* ********************************************************************** *)
(** * Properties of Subtyping *)

(* ********************************************************************** *)
(** Reflexivity (1) *)

Lemma sub_reflexivity : forall E T,
  okt E ->
  wft E T ->
  sub E T T .
Proof.
  introv Ok WI. lets W: (wft_type WI). gen E.
  induction W; intros; inversions WI; eauto.
  apply* sub_and2. apply* sub_and11. apply* sub_and12.
  apply* sub_or1. apply* sub_or21. apply* sub_or22.
  apply* sub_mem.
  apply_fresh* sub_all as Y.
Qed.

(* ********************************************************************** *)
(** Weakening (2) *)

Lemma sub_has_weakening : (forall E0 S T, sub E0 S T -> forall E F G,
   E0 = E & G ->
   okt (E & F & G) ->
   sub (E & F & G) S T) /\ (forall E0 p T, has E0 p T -> forall E F G,
   E0 = E & G ->
   okt (E & F & G) ->
   has (E & F & G) p T).
Proof.
  apply sub_has_mutind; intros; subst; auto.
  apply* sub_and11.
  apply* sub_and12.
  apply* sub_and2.
  apply* sub_or21.
  apply* sub_or22.
  apply* sub_or1.
  apply* sub_sel1.
  apply* sub_sel2.
  apply* sub_mem.
  apply_fresh* sub_all as Y. apply_ih_bind* H0.
  apply* sub_trans.
  apply* has_var. apply* binds_weaken.
  apply* has_mem.
  apply* has_abs. apply* wfe_weaken.
  apply* has_sub.
Qed.

Lemma sub_weakening : forall E F G S T,
   sub (E & G) S T ->
   okt (E & F & G) ->
   sub (E & F & G) S T.
Proof.
  intros. apply* (proj1 sub_has_weakening).
Qed.

Lemma sub_weakening1 : forall E F G S T,
   sub E S T ->
   okt (E & F & G) ->
   sub (E & F & G) S T.
Proof.
  intros.
  assert (E & F & G = E & (F & G) & empty) as A. {
    rewrite concat_empty_r. rewrite concat_assoc. reflexivity.
  }
  rewrite A.
  apply* sub_weakening.
  rewrite concat_empty_r. assumption.
  rewrite <- A. assumption.
Qed.

Lemma sub_weakening_empty : forall E S T,
   sub empty S T ->
   okt E ->
   sub E S T.
Proof.
  intros.
  assert (empty & E & empty = E) as A. {
    rewrite concat_empty_r. rewrite concat_empty_l. reflexivity.
  }
  rewrite <- A.
  apply* sub_weakening.
  rewrite concat_empty_r. assumption.
  rewrite A. assumption.
Qed.

Lemma has_weakening : forall E F G p T,
   has (E & G) p T ->
   okt (E & F & G) ->
   has (E & F & G) p T.
Proof.
  intros. apply* (proj2 sub_has_weakening).
Qed.

Lemma has_weakening1 : forall E F G p T,
   has E p T ->
   okt (E & F & G) ->
   has (E & F & G) p T.
Proof.
  intros.
  assert (E & F & G = E & (F & G) & empty) as A. {
    rewrite concat_empty_r. rewrite concat_assoc. reflexivity.
  }
  rewrite A.
  apply* has_weakening.
  rewrite concat_empty_r. assumption.
  rewrite <- A. assumption.
Qed.

Lemma has_weakening_empty : forall E p T,
   has empty p T ->
   okt E ->
   has E p T.
Proof.
  intros.
  assert (empty & E & empty = E) as A. {
    rewrite concat_empty_r. rewrite concat_empty_l. reflexivity.
  }
  rewrite <- A.
  apply* has_weakening.
  rewrite concat_empty_r. assumption.
  rewrite A. assumption.
Qed.

(* ********************************************************************** *)
(** Narrowing and transitivity (3) *)

Section NarrowTrans.

Hint Resolve wft_narrow.

Lemma sub_has_narrowing_aux :
  (forall E0 S T, sub E0 S T ->
   forall Q E F z P,
   E0 = (E & z ~ Q & F) ->
   sub E P Q ->
   sub (E & z ~ P & F) S T)
  /\
  (forall E0 p T, has E0 p T ->
   forall Q E F z P,
   E0 = (E & z ~ Q & F) ->
   sub E P Q ->
   has (E & z ~ P & F) p T).
Proof.
  Hint Constructors sub has.
  apply sub_has_mutind; intros; subst; eauto 4.
  apply* sub_bot.
  apply* sub_top.
  apply* sub_and11.
  apply* sub_and12.
  apply* sub_or21.
  apply* sub_or22.
  apply* sub_refl_sel.
  apply_fresh sub_all as Y. auto*. apply_ih_bind H0; eauto 4.
  tests EQ: (x = z).
    lets M: (@okt_narrow Q).
    apply binds_middle_eq_inv in b. subst.
    eapply has_sub. eapply has_var. apply* M. apply binds_middle_eq.
      eapply ok_from_okt in o. eapply ok_middle_inv in o. destruct o as [o1 o2]. apply o2.
      eapply sub_weakening1; eauto.
      auto*.
    eapply has_var; eauto. binds_cases b; auto.
  apply* has_mem.
  apply* has_abs. eapply (proj2 wf_narrow); eauto.
Qed.

Lemma sub_narrowing : forall Q E F Z P S T,
  sub E P Q ->
  sub (E & Z ~ Q & F) S T ->
  sub (E & Z ~ P & F) S T.
Proof.
  intros.
  apply* (proj1 sub_has_narrowing_aux).
Qed.

Lemma sub_narrowing_empty : forall Q Z P S T,
  sub empty P Q ->
  sub (Z ~ Q) S T ->
  sub (Z ~ P) S T.
Proof.
  intros.
  rewrite <- (concat_empty_r (Z ~ P)).
  rewrite <- (concat_empty_l (Z ~ P)).
  eapply sub_narrowing; eauto 4.
  rewrite concat_empty_r. rewrite concat_empty_l. auto.
Qed.

End NarrowTrans.

(* ********************************************************************** *)
(** Substitution preserves subtyping (10) *)

Lemma has_value_var : forall E u T,
  has E u T ->
  (value u \/ exists x, trm_fvar x = u).
Proof.
  intros. apply has_regular_e in H. destruct H as [A ?].
  apply A.
Qed.

Hint Resolve has_value_var.

Lemma var_typing_has: forall E x Q,
  typing E (trm_fvar x) Q ->
  has E (trm_fvar x) Q.
Proof.
  introv H. remember (trm_fvar x) as t. gen Heqt.
  induction H; intros; subst; try solve [inversion Heqt].
  - inversion Heqt. subst. apply* has_var.
  - eapply has_sub. eapply IHtyping; eauto. assumption.
Qed.

Lemma val_typing_has: forall E u Q,
  value u ->
  typing E u Q ->
  has E u Q.
Proof.
  introv Hv H.
  lets R: (typing_regular H).
  induction H; intros; subst; try solve [inversion Hv].
  - apply* has_abs.
  - apply* has_mem.
  - apply* has_sub.
Qed.

Lemma sub_has_through_subst : (forall E0 S T, sub E0 S T -> forall Q E F Z u,
  E0 = (E & Z ~ Q & F) ->
  (value u \/ exists x, trm_fvar x = u) -> typing E u Q ->
  sub (E & map (subst_t Z u) F) (subst_t Z u S) (subst_t Z u T)) /\
  (forall E0 p T, has E0 p T -> forall Q E F Z u,
  E0 = (E & Z ~ Q & F) ->
  (value u \/ exists x, trm_fvar x = u) -> typing E u Q ->
  has (E & map (subst_t Z u) F) (subst_e Z u p) (subst_t Z u T)).
Proof.
  apply sub_has_mutind; intros; subst; simpl.
  - apply* sub_bot.
  - apply* sub_top.
  - apply* sub_and11.
  - apply* sub_and12.
  - apply* sub_and2.
  - apply* sub_or21.
  - apply* sub_or22.
  - apply* sub_or1.
  - simpl. apply* sub_refl_sel.
    assert (typ_sel (subst_e Z u t) = subst_t Z u (typ_sel t)) as A by auto.
    rewrite A. auto*.
  - apply* sub_sel1. eapply H. reflexivity. auto. auto.
  - apply* sub_sel2. eapply H. reflexivity. auto. auto.
  - apply* sub_mem.
  - apply_fresh* sub_all as X.
    rewrite* subst_t_open_t_var. rewrite* subst_t_open_t_var.
    apply_ih_map_bind* H0.
  - apply* sub_trans.
  - case_var.
    + apply binds_middle_eq_inv in b; eauto. subst.
      destruct H0 as [H0 | [x H0]].
      * apply_empty* has_weakening1.
        rewrite (proj1 subst_fresh). apply* val_typing_has.
        apply* (@notin_fv_wf E0).
      * subst. rewrite (proj1 subst_fresh).
        apply_empty* has_weakening1. apply var_typing_has. assumption.
        apply* (@notin_fv_wf E0).
    + destruct (binds_concat_inv b) as [?|[? ?]].
      * eapply has_var. auto*.
        apply binds_concat_right. apply binds_map. eassumption.
      * applys has_var. apply* okt_subst.
        assert (T = subst_t Z u T) as B. {
          rewrite (proj1 subst_fresh). reflexivity.
          apply* (@notin_fv_wf E0). apply* wft_from_env_has.
          apply binds_concat_left_inv in H2. eassumption.
          auto*.
        }
        apply binds_concat_left. rewrite <- B.
        apply binds_concat_left_inv in H2. apply H2.
        auto*. auto*.
  - apply* has_mem.
  - apply* has_abs.
    assert (trm_abs (subst_t Z u V) (subst_e Z u e) =
            subst_e Z u (trm_abs V e)) as A by solve [simpl; reflexivity].
    rewrite A. eapply (proj2 wf_subst); eauto.
    assert (typ_all (subst_t Z u V) (subst_t Z u T) =
            subst_t Z u (typ_all V T)) as B by solve [simpl; reflexivity].
    rewrite B. apply* wft_subst.
  - apply* has_sub.
Qed.

(* ********************************************************************** *)
(** * Properties of Typing *)

(* ********************************************************************** *)
(** Weakening (5) *)

Lemma typing_weakening : forall E F G e T,
   typing (E & G) e T ->
   okt (E & F & G) ->
   typing (E & F & G) e T.
Proof.
  introv Typ. gen F. inductions Typ; introv Ok.
  apply* typing_var. apply* binds_weaken.
  apply_fresh* typing_abs as x. forwards~ K: (H x).
   apply_ih_bind (H0 x); eauto.
  apply* typing_mem.
  apply* typing_app.
  eapply typing_appvar; eauto. eapply (proj2 sub_has_weakening); eauto.
  apply* typing_sub. apply* sub_weakening.
Qed.

(************************************************************************ *)
(** Preservation by Type Narrowing (7) *)

Lemma typing_narrowing : forall Q E F X P e T,
  sub E P Q ->
  typing (E & X ~ Q & F) e T ->
  typing (E & X ~ P & F) e T.
Proof.
  introv PsubQ Typ. gen_eq E': (E & X ~ Q & F). gen F.
  inductions Typ; introv EQ; subst; simpl.
  - binds_cases H0.
    + apply* typing_var.
    + subst. apply* typing_sub. apply* sub_weakening1.
    + apply* typing_var.
  - apply_fresh* typing_abs as y. apply_ih_bind* H0.
  - apply* typing_mem. apply* wft_narrow.
  - apply* typing_app. apply* wft_narrow.
  - apply* typing_appvar. apply* (proj2 sub_has_narrowing_aux). apply* wft_narrow.
  - apply* typing_sub. apply* (@sub_narrowing Q).
Qed.

Lemma typing_narrowing_empty : forall Q X P e T,
  sub empty P Q ->
  typing (X ~ Q) e T ->
  typing (X ~ P) e T.
Proof.
  intros.
  rewrite <- (concat_empty_r (X ~ P)).
  rewrite <- (concat_empty_l (X ~ P)).
  eapply typing_narrowing; eauto.
  rewrite concat_empty_r. rewrite concat_empty_l. auto.
Qed.

(************************************************************************ *)
(** Preservation by Substitution (8) *)

Lemma typing_through_subst : forall U E F z T e u,
  typing (E & z ~ U & F) e T ->
  (value u \/ exists x, trm_fvar x = u) -> typing E u U ->
  typing (E & (map (subst_t z u) F)) (subst_e z u e) (subst_t z u T).
Proof.
  introv TypT Hu TypU.
  inductions TypT; introv; subst; simpl.
  - case_var.
    + binds_get H0.
      rewrite (proj1 subst_fresh).
      apply_empty typing_weakening. assumption.
      apply* okt_subst.
      apply* (@notin_fv_wf E).
    + binds_cases H0.
      rewrite (proj1 subst_fresh). eapply typing_var; eauto.
      apply (@notin_fv_wf E). eapply wft_from_env_has. auto*. eapply B0. auto*.
      apply* typing_var.
  - apply_fresh* typing_abs as y.
    rewrite* subst_e_open_e_var. rewrite* subst_t_open_t_var.
    rewrite <- concat_assoc_map_push.
    eapply H0; eauto. rewrite concat_assoc. auto.
  - apply* typing_mem.
  - eapply typing_app. eapply IHTypT1; eauto. eapply IHTypT2; eauto.
    apply* wft_subst.
  - eapply typing_appvar. eapply IHTypT1; eauto. eapply IHTypT2; eauto.
    apply* (proj2 sub_has_through_subst).
    eapply subst_t_open_t. auto*. apply* wft_subst.
  - eapply typing_sub. eapply IHTypT; eauto.
    eapply (proj1 sub_has_through_subst); eauto.
Qed.

(* ********************************************************************** *)
(** * Preservation *)

(* ********************************************************************** *)
(** Inversions for Typing (13) *)

Inductive psub : typ -> typ -> Prop :=
  | psub_bot : forall U,
      wft empty U ->
      psub typ_bot U
  | psub_top : forall S,
      wft empty S ->
      psub S typ_top
  | psub_and11 : forall T1 T2 T,
      wft empty T2 ->
      psub T1 T ->
      psub (typ_and T1 T2) T
  | psub_and12 : forall T1 T2 T,
      wft empty T1 ->
      psub T2 T ->
      psub (typ_and T1 T2) T
  | psub_and2 : forall T T1 T2,
      psub T T1 ->
      psub T T2 ->
      psub T (typ_and T1 T2)
  | psub_or21 : forall T T1 T2,
      wft empty T2 ->
      psub T T1 ->
      psub T (typ_or T1 T2)
  | psub_or22 : forall T T1 T2,
      wft empty T1 ->
      psub T T2 ->
      psub T (typ_or T1 T2)
  | psub_or1 : forall T1 T2 T,
      psub T1 T->
      psub T2 T ->
      psub (typ_or T1 T2) T
  | psub_refl_sel : forall t,
      wft empty (typ_sel t) ->
      psub (typ_sel t) (typ_sel t)
  | psub_sel1 : forall U,
      wft empty U ->
      psub (typ_sel (trm_mem U)) U
  | psub_sel2 : forall S,
      wft empty S ->
      psub S (typ_sel (trm_mem S))
  | psub_mem : forall S1 U1 S2 U2,
      psub S2 S1 -> psub U1 U2 ->
      psub (typ_mem S1 U1) (typ_mem S2 U2)
  | psub_all : forall L S1 S2 T1 T2,
      psub T1 S1 ->
      (forall x, x \notin L ->
          sub (x ~ T1) (S2 open_t_var x) (T2 open_t_var x)) ->
      psub (typ_all S1 S2) (typ_all T1 T2)
  | psub_trans : forall S T U,
      psub S T ->
      psub T U ->
      psub S U
.

Lemma has_empty_value: forall p T,
  has empty p T ->
  value p.
Proof.
  intros. apply has_regular_e in H.
  destruct H as [[HV | [x Eq]] Hwf].
  - assumption.
  - subst. inversion Hwf; subst. false. apply* binds_empty_inv.
Qed.

Hint Constructors psub.

Lemma psub_sub: forall S T,
  psub S T -> sub empty S T.
Proof.
  intros. induction H; eauto.
  - apply* sub_and11.
  - apply* sub_and12.
  - apply* sub_and2.
  - apply* sub_or21.
  - apply* sub_or22.
  - apply* sub_or1.
  - apply* sub_sel1. apply* has_mem.
  - apply* sub_sel2. apply* has_mem.
  - apply* sub_mem.
  - apply_fresh* sub_all as y.
    rewrite concat_empty_l. auto*.
  - eapply sub_trans; eauto.
Qed.

Inductive possible_types : nat -> trm -> typ -> Prop :=
| pt_top : forall n v, value v -> wfe empty v -> possible_types n v typ_top
| pt_mem : forall n T S U, psub S T -> psub T U -> possible_types n (trm_mem T) (typ_mem S U)
| pt_all : forall L n V V' e1 T1 T1',
  (forall X, X \notin L -> typing (X ~ V) (e1 open_e_var X) (T1 open_t_var X)) ->
  psub V' V ->
  (forall X, X \notin L -> sub (X ~ V') (T1 open_t_var X) (T1' open_t_var X)) ->
  possible_types (S n) (trm_abs V e1) (typ_all V' T1')
| pt_all_shallow : forall V V' e1 T1',
  wfe empty (trm_abs V e1) -> wft empty (typ_all V' T1') ->
  possible_types 0 (trm_abs V e1) (typ_all V' T1')
| pt_sel : forall n v S,
  possible_types n v S ->
  possible_types n v (typ_sel (trm_mem S))
| pt_and : forall n v T1 T2,
  possible_types n v T1 ->
  possible_types n v T2 ->
  possible_types n v (typ_and T1 T2)
| pt_or1 : forall n v T1 T2,
  possible_types n v T1 ->
  wft empty T2 ->
  possible_types n v (typ_or T1 T2)
| pt_or2 : forall n v T1 T2,
  possible_types n v T2 ->
  wft empty T1 ->
  possible_types n v (typ_or T1 T2)
.

Lemma possible_types_value : forall n p T,
  possible_types n p T ->
  value p.
Proof.
  introv Hpt. induction Hpt; eauto.
  - apply psub_sub in H. auto*.
  - apply value_abs. apply_fresh* term_abs as y.
    apply psub_sub in H0. auto*.
    assert (y \notin L) as Fr by auto.
    specialize (H y Fr). apply typing_regular in H.
    destruct H as [? [A ?]]. apply* wfe_term.
  - apply value_abs. apply* wfe_term.
Qed.

Lemma possible_types_wfe : forall n p T,
  possible_types n p T ->
  wfe empty p.
Proof.
  introv Hpt. induction Hpt; eauto.
  - apply psub_sub in H. auto*.
  - apply_fresh* wfe_abs as y.
    apply psub_sub in H0. auto*.
    assert (y \notin L) as FrL by auto. specialize (H y FrL).
    apply typing_regular in H. destruct H as [? [A ?]].
    rewrite concat_empty_l. assumption.
Qed.

Lemma possible_types_wft : forall n p T,
  possible_types n p T ->
  wft empty T.
Proof.
  introv Hpt. induction Hpt; eauto.
  - apply psub_sub in H. apply psub_sub in H0. apply* wft_mem.
  - apply_fresh* wft_all as y.
    apply psub_sub in H0. auto*.
    assert (y \notin L) as FrL by auto. specialize (H1 y FrL).
    apply sub_regular in H1. destruct H1 as [? [? A]].
    rewrite concat_empty_l. assumption.
  - apply wft_sel. left. apply value_mem. apply* wfe_term. apply* wfe_mem.
Grab Existential Variables.
pick_fresh y. apply y.
pick_fresh y. apply y.
pick_fresh y. apply y.
Qed.

Lemma has_empty_var_false: forall x T,
  has empty (trm_fvar x) T ->
  False.
Proof.
  intros.
  remember (trm_fvar x) as p. generalize dependent x.
  remember empty as E. gen HeqE.
  induction H; intros; subst; eauto.
  - apply* binds_empty_inv.
  - inversion Heqp.
  - inversion Heqp.
Qed.

Lemma possible_types_closure_psub : forall n v T U,
  possible_types n v T ->
  psub T U ->
  possible_types n v U.
Proof.
  introv Hpt Hsub. generalize dependent v.
  induction Hsub; intros; subst; eauto.
  - inversion Hpt.
  - apply pt_top. apply* possible_types_value. apply* possible_types_wfe.
  - inversion Hpt; subst. apply IHHsub. assumption.
  - inversion Hpt; subst. apply IHHsub. assumption.
  - apply* pt_and.
  - apply* pt_or1.
  - apply* pt_or2.
  - inversion Hpt; subst. apply IHHsub1. assumption. apply IHHsub2. assumption.
  - inversion Hpt; subst. assumption.
  - apply* pt_sel.
  - inversion Hpt; subst.
    apply pt_mem. eapply psub_trans; eauto. eapply psub_trans; eauto.
  - inversion Hpt; subst. apply_fresh* pt_all as y.
    eapply sub_trans.
    eapply sub_narrowing_empty. eapply psub_sub. eassumption. auto*. auto*.
    apply pt_all_shallow; eauto. apply_fresh* wft_all as y.
    apply psub_sub in Hsub. auto*.
    rewrite concat_empty_l.
    assert (y \notin L) as Fr by auto. specialize (H y Fr). auto*.
Qed.

Lemma psub_reflexivity : forall T,
  wft empty T ->
  psub T T .
Proof.
  introv WI. lets W: (wft_type WI). remember empty as E. gen E.
  induction W; intros; inversions WI; eauto 4.
  apply* psub_and2.
  apply* psub_or1.
  apply_fresh* psub_all as y.
  assert (y \notin L0)as Fr0 by auto. specialize (H5 y Fr0).
  rewrite concat_empty_l in H5.
  apply* sub_reflexivity. rewrite <- concat_empty_l. apply* okt_push.
Qed.

Lemma sub_psub_aux:
  (forall E S T, sub E S T -> E = empty -> psub S T) /\
  (forall E p T, has E p T -> E = empty -> possible_types 0 p T).
Proof.
  apply sub_has_mutind; intros; subst; eauto 4.
  - specialize (H eq_refl).
    inversion H; subst.
    eapply psub_trans. eapply psub_sel1.
    apply psub_sub in H4. auto*.
    assumption.
  - specialize (H eq_refl).
    inversion H; subst.
    eapply psub_trans. eassumption. eapply psub_sel2.
    apply psub_sub in H4. auto*.
  - apply_fresh* psub_all as y.
    rewrite <- (@concat_empty_l typ (y ~ T1)). auto*.
  - false. apply* binds_empty_inv.
  - apply pt_mem; eauto.
  - apply* pt_all_shallow.
  - eapply possible_types_closure_psub; eauto.
Qed.

Lemma sub_psub: forall S T,
  sub empty S T -> psub S T.
Proof.
  intros. apply* (proj1 sub_psub_aux).
Qed.

Lemma possible_types_closure : forall n v T U,
  possible_types n v T ->
  sub empty T U ->
  possible_types n v U.
Proof.
  intros. eapply possible_types_closure_psub; eauto 4.
  apply* sub_psub.
Qed.

Lemma possible_types_typing : forall v T,
  typing empty v T -> value v ->
  possible_types 1 v T.
Proof.
  introv Ht Hv.
  remember Ht as Hc. clear HeqHc.
  remember empty as E. generalize HeqE. generalize Hc.
  induction Ht; intros; subst; eauto; try solve [inversion Hv].
  - eapply typing_regular in Hc. destruct Hc as [? [? Hc]].
    inversion Hc; subst.
    apply_fresh pt_all as Y.
    assert (Y \notin L) as Fr by eauto.
    specialize (H Y Fr). rewrite concat_empty_l in H. eapply H.
    eapply psub_reflexivity; eauto. eapply sub_reflexivity; eauto.
    rewrite <- concat_empty_l. eauto.
    assert (Y \notin L0) as Fr by eauto.
    specialize (H7 Y Fr). rewrite concat_empty_l in H7. eapply H7.
  - apply pt_mem. apply* psub_reflexivity. apply* psub_reflexivity.
  - eapply possible_types_closure; eauto.
Qed.

Lemma typing_inv_abs : forall S1 e1 T,
  typing empty (trm_abs S1 e1) T ->
  forall U1 U2, sub empty T (typ_all U1 U2) ->
     sub empty U1 S1
  /\ exists S2, exists L, forall x, x \notin L ->
     typing (x ~ S1) (e1 open_e_var x) (S2 open_t_var x) /\ sub (x ~ U1) (S2 open_t_var x) (U2 open_t_var x).
Proof.
  introv Typ Hsub.
  apply possible_types_typing in Typ; eauto.
  assert (possible_types 1 (trm_abs S1 e1) (typ_all U1 U2)) as Hc. {
    eapply possible_types_closure; eauto.
  }
  inversion Hc; subst.
  repeat eexists; eauto.
  apply* psub_sub.
Qed.

(** Canonical Forms (14) *)

Lemma canonical_form_abs : forall t U1 U2,
  value t -> typing empty t (typ_all U1 U2) ->
  exists V, exists e1, t = trm_abs V e1.
Proof.
  introv Val Typ.
  eapply possible_types_typing in Typ; eauto.
  inversion Typ; subst; eauto.
Qed.

Lemma canonical_form_mem : forall t b T,
  value t -> typing empty t (typ_mem b T) ->
  exists V, t = trm_mem V.
Proof.
  introv Val Typ.
  eapply possible_types_typing in Typ; eauto.
  inversion Typ; subst; eauto.
Qed.

Lemma typing_through_subst1 : forall V y v e T,
  typing (y ~ V) e T ->
  value v -> typing empty v V ->
  typing empty (subst_e y v e) (subst_t y v T).
Proof.
  intros.
  assert (empty & map (subst_t y v) empty = empty) as A. {
    rewrite concat_empty_l. rewrite map_empty. reflexivity.
  }
  rewrite <- A. eapply typing_through_subst.
  rewrite concat_empty_l. rewrite concat_empty_r. eauto.
  left. assumption. assumption.
Qed.

(* ********************************************************************** *)
(** Preservation Result (20) *)

Lemma value_red_contra: forall e e',
  value e -> red e e' -> False.
Proof.
  introv Hv Hr. inversion Hv; subst; inversion Hr; subst; eauto.
Qed.

Lemma preservation_result : preservation.
Proof.
  introv Typ. gen_eq E: (@empty typ). gen e'.
  induction Typ; introv QEQ; introv Red;
   try solve [inversion Typ; congruence]; try solve [ inversion Red ].
  - (* case: app *)
    inversions Red; try solve [ apply* typing_app ].
    destruct~ (typing_inv_abs Typ1 (U1:=T1) (U2:=T2)) as [P1 [S2 [L P2]]].
     apply* sub_reflexivity.
     pick_fresh X. forwards~ K: (P2 X). destruct K.
      rewrite* (@subst_e_intro X).
      erewrite <- (proj1 subst_fresh).
      eapply typing_through_subst1.
      eapply typing_sub. eapply typing_narrowing_empty. eapply P1. eassumption.
      rewrite <- (@open_t_var_type X).
      assert (X \notin L) as FrL by auto.
      specialize (P2 X FrL). destruct P2 as [P2t P2s].
      eassumption. apply* wft_type. assumption. assumption. auto*.
  - (* case: appvar *)
    inversions Red; try solve [ apply* typing_appvar ].
    lets HV2: (has_empty_value H). false. eapply value_red_contra in HV2; eauto.
    destruct~ (typing_inv_abs Typ1 (U1:=T1) (U2:=T2)) as [P1 [S2 [L P2]]].
    apply* sub_reflexivity.
    pick_fresh X. forwards~ K: (P2 X). destruct K.
     rewrite* (@subst_t_intro X).
     rewrite* (@subst_e_intro X).
     eapply typing_through_subst1.
     eapply typing_sub. eapply typing_narrowing_empty. eapply P1. eassumption.
     assert (X \notin L) as FrL by auto.
     specialize (P2 X FrL). destruct P2 as [P2t P2s].
     eassumption. assumption. assumption.
  - (* case sub *)
    apply* typing_sub.
Qed.

(* ********************************************************************** *)
(** * Progress *)

(* ********************************************************************** *)

(* ********************************************************************** *)
(** Progress Result (16) *)

Lemma progress_result : progress.
Proof.
  introv Typ. gen_eq E: (@empty typ). lets Typ': Typ.
  induction Typ; intros EQ; subst.
  - (* case: var *)
    false* binds_empty_inv.
  - (* case: abs *)
    left*.
  - (* case: mem *)
    left*.
  - (* case: app *)
    right. destruct* IHTyp1 as [Val1 | [e1' Rede1']].
    destruct* IHTyp2 as [Val2 | [e2' Rede2']].
      destruct (canonical_form_abs Val1 Typ1) as [S [e3 EQ]].
        subst. exists* (open_e e3 e2).
  - (* case: appvar *)
    right. destruct* IHTyp1 as [Val1 | [e1' Rede1']].
    destruct* IHTyp2 as [Val2 | [e2' Rede2']].
      destruct (canonical_form_abs Val1 Typ1) as [S [e3 EQ]].
        subst. exists* (open_e e3 e2).
  - (* case: sub *)
    auto*.
Qed.


Require Import List.
Import ListNotations.

Set Implicit Arguments.

Ltac break_match :=
  match goal with
    | [ |- context [ match ?X with _ => _ end ] ] =>
      match type of X with
        | sumbool _ _ => destruct X
        | _ => destruct X eqn:?
      end
  end.

Ltac do_in_app :=
  match goal with
    | [ H : In _ (_ ++ _) |- _ ] => apply in_app_iff in H
  end.

Section dedup.
  Variable A : Type.
  Hypothesis A_eq_dec : forall x y : A, {x = y} + {x <> y}.

  Fixpoint dedup (xs : list A) : list A :=
    match xs with
    | [] => []
    | x :: xs => let tail := dedup xs in
                 if in_dec A_eq_dec x xs then
                   tail
                 else
                   x :: tail
    end.

  Lemma dedup_app : forall (xs ys : list A),
      (forall x y, In x xs -> In y ys -> x <> y) ->
      dedup (xs ++ ys) = dedup xs ++ dedup ys.
  Proof using.
    intros. induction xs; simpl; auto.
    repeat break_match.
    - apply IHxs.
      intros.
      apply H; intuition.
    - exfalso.
      specialize (H a a).
      apply H; intuition.
      do_in_app.
      intuition.
    - exfalso.
      apply n.
      intuition.
    - simpl.
      f_equal.
      apply IHxs.
      intros.
      apply H; intuition.
  Qed.

End dedup.