Require Export SfLib.

Require Export Arith.EqNat.

Require Export Arith.Le.

(*
subtyping:
  - looking at single-environment case again.
  - new pushback proof structure: transitivity axiom only
    needed in contravariant positions
  - realizable type: precise expansion, and upper bounds
    are also realizable

 TODO/QUESTIONs:
  - bind2/bind1 rules?
  - intersection/union types?
  - restrictions: recursive members?
  - if lower bound is bottom, must upper bound still be realizable?
    --> cannot be part of nontrivial T1 < x.A < T2 chain
*)

(* ############################################################ *)
(* Syntax *)
(* ############################################################ *)

Module DOT.

Definition id := nat.

Inductive ty : Type :=
  | TNoF   : ty (* marker for empty method list *)

  | TBot   : ty
  | TTop   : ty
  | TBool  : ty
  | TAnd   : ty -> ty -> ty
  | TFun   : id -> ty -> ty -> ty
  | TMem   : ty -> ty -> ty
  | TSel   : id -> ty

  | TSelB  : id -> ty
  | TBind  : ty -> ty
.

Inductive tm : Type :=
  | ttrue : tm
  | tfalse : tm
  | tvar : id -> tm
  | tapp : id -> id -> tm -> tm (* a.f(x) *)
  | tabs : id -> ty -> list (id * dc) -> tm -> tm (* let f:T = x => y in z *)
  | tlet : id -> ty -> tm -> tm -> tm (* let x:T = y *)
with dc: Type :=
  | dfun : ty -> ty -> id -> tm -> dc (* def m:T = x => y *)
.

Fixpoint dc_type_and (dcs: list(nat*dc)) :=
  match dcs with
    | nil => TNoF
    | (n, dfun T1 T2 _ _)::dcs =>
      TAnd (TFun (length dcs) T1 T2)  (dc_type_and dcs)
  end.

Definition TObj p dcs := TAnd (TMem p p) (dc_type_and dcs).
Definition TArrow p x y := TAnd (TMem p p) (TAnd (TFun 0 x y) TNoF).

Inductive vl : Type :=
| vbool : bool -> vl
| vabs  : list (id*vl) -> id -> ty -> list (id * dc) -> vl (* clos env f:T = x => y *)
| vmock : list (id*vl) -> ty -> id -> id -> vl
.

Definition env := list (nat*vl).
Definition tenv := list (nat*ty).

Fixpoint index {X : Type} (n : nat)
               (l : list (nat * X)) : option X :=
  match l with
    | [] => None
    (* for now, ignore binding value n' !!! *)
    | (n',a) :: l'  => if beq_nat n (length l') then Some a else index n l'
  end.

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

(* LOCALLY NAMELESS *)

Inductive closed_rec: nat -> ty -> Prop :=
| cl_nof: forall k,
    closed_rec k TNoF
| cl_top: forall k,
    closed_rec k TTop
| cl_bot: forall k,
    closed_rec k TBot
| cl_bool: forall k,
    closed_rec k TBool
| cl_fun: forall k m T1 T2,
    closed_rec k T1 ->
    closed_rec k T2 ->
    closed_rec k (TFun m T1 T2)
| cl_mem: forall k T1 T2,
    closed_rec k T1 ->
    closed_rec k T2 ->
    closed_rec k (TMem T1 T2)
| cl_and: forall k T1 T2,
    closed_rec k T1 ->
    closed_rec k T2 ->
    closed_rec k (TAnd T1 T2)
| cl_bind: forall k T1,
    closed_rec (S k) T1 ->
    closed_rec k (TBind T1)
| cl_sel: forall k x,
    closed_rec k (TSel x)
| cl_selb: forall k i,
    k > i ->
    closed_rec k (TSelB i)
.

Hint Constructors closed_rec.

Definition closed j T := closed_rec j T.

Fixpoint open_rec (k: nat) (u: id) (T: ty) { struct T }: ty :=
  match T with
    | TSel x      => TSel x (* free var remains free. functional, so we can't check for conflict *)
    | TSelB i     => if beq_nat k i then TSel u else TSelB i
    | TBind T1    => TBind (open_rec (S k) u T1)
    | TNoF        => TNoF
    | TBot => TBot
    | TTop => TTop
    | TBool       => TBool
    | TAnd T1 T2  => TAnd (open_rec k u T1) (open_rec k u T2)
    | TMem T1 T2  => TMem (open_rec k u T1) (open_rec k u T2)
    | TFun m T1 T2  => TFun m (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 9 (TBind (TAnd (TMem TBot TTop) (TFun 0 (TSelB 1) (TSelB 0)))) =
                      (TBind (TAnd (TMem TBot TTop) (TFun 0 (TSel  9) (TSelB 0)))).
Proof. compute. eauto. Qed.

Lemma closed_no_open: forall T x j,
  closed_rec j 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 T,
 closed_rec i T ->
 j >= i ->
 closed_rec j T.
Proof.
 intros. generalize dependent j. induction H; intros; eauto.
 Case "TBind". econstructor. eapply IHclosed_rec. omega.
 Case "TSelB". econstructor. omega.
Qed.

Hint Unfold open.
Hint Unfold closed.

(* ############################################################ *)
(* Static properties: type assignment, subtyping, ... *)
(* ############################################################ *)

(* TODO: wf is not up to date *)

(* static type expansion.
   needs to imply dynamic subtyping / value typing. *)
Inductive tresolve: id -> ty -> ty -> Prop :=
  | tr_self: forall x T,
             tresolve x T T
  | tr_and1: forall x T1 T2 T,
             tresolve x T1 T ->
             tresolve x (TAnd T1 T2) T
  | tr_and2: forall x T1 T2 T,
             tresolve x T2 T ->
             tresolve x (TAnd T1 T2) T
  | tr_unpack: forall x T2 T3 T,
             open x T2 = T3 ->
             tresolve x T3 T ->
             tresolve x (TBind T2) T
.

Tactic Notation "tresolve_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "Self" |
    Case_aux c "And1" |
    Case_aux c "And2" |
    Case_aux c "Bind" ].

(* static type well-formedness.
   needs to imply dynamic subtyping. *)
Inductive wf_type : tenv -> ty -> Prop :=
| wf_top: forall env,
    wf_type env TNoF
| wf_bool: forall env,
    wf_type env TBool
| wf_and: forall env T1 T2,
             wf_type env T1 ->
             wf_type env T2 ->
             wf_type env (TAnd T1 T2)
| wf_mem: forall env TL TU,
             wf_type env TL ->
             wf_type env TU ->
             wf_type env (TMem TL TU)
| wf_fun: forall env f T1 T2,
             wf_type env T1 ->
             wf_type env T2 ->
             wf_type env (TFun f T1 T2)

| wf_sel: forall envz x TE TL TU,
            index x envz = Some (TE) ->
            tresolve x TE (TMem TL TU) ->
            wf_type envz (TSel x)

| wf_selb: forall envz x, (* note: disregarding bind-scope *)
             wf_type envz (TSelB x)
| wf_bind: forall envz T,
             wf_type envz T ->
             wf_type envz (TBind T)

.

Tactic Notation "wf_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "Top" |
    Case_aux c "Bool" |
    Case_aux c "And" |
    Case_aux c "MemA" |
    Case_aux c "Mem" |
    Case_aux c "Fun" |
    Case_aux c "Sel" |
    Case_aux x "SelB" |
    Case_aux c "Bind" ].

Inductive stp : bool -> tenv -> ty -> ty -> nat -> Prop :=

| stp_bot: forall G1 T n1,
    stp true G1 TBot T n1

| stp_top: forall G1 T n1,
    stp true G1 T TTop n1

| stp_bool: forall G1 n1,
    stp true G1 TBool TBool n1

| stp_fun: forall m G1 T11 T12 T21 T22 n1 n2,
    stp false G1 T21 T11 n1 ->
    stp true G1 T12 T22 n2 ->
    stp true G1 (TFun m T11 T12) (TFun m T21 T22) (S (n1+n2))

| stp_mem: forall G1 T11 T12 T21 T22 n1 n2 n3,
    stp false G1 T21 T11 n1 ->
    stp true G1 T11 T12 n2 -> (* NOT SO EASY TO ADD: build_mem! *)
    stp true G1 T12 T22 n3 ->
    stp true G1 (TMem T11 T12) (TMem T21 T22) (S (n1+n2+n3))

| stp_sel2: forall x T1 TX G1 n1 n2,
    index x G1 = Some TX ->
    itp G1 TX n2 ->
    stp true G1 TX (TMem T1 TTop) n1 ->
    stp true G1 T1 (TSel x) (S (n1+n2))
| stp_sel1: forall x T2 TX G1 n1 n2,
    index x G1 = Some TX ->
    itp G1 TX n2 ->
    stp true G1 TX (TMem TBot T2) n1 ->
    stp true G1 (TSel x) T2 (S (n1+n2))
| stp_selx: forall x G1 n1,
    stp true G1 (TSel x) (TSel x) (S n1)

(* TODO!
| stp_bind2: forall f G1 T1 T2 TA2 n1,
    stp true ((f,T1)::G1) T1 T2 n1 ->
    open (length G1) TA2 = T2 ->
    stp true G1 T1 (TBind TA2) (S n1)
| stp_bind1: forall f G1 T1 T2 TA1 n1,
    stp true ((f,T1)::G1) T1 T2 n1 ->
    open (length G1) TA1 = T1 ->
    stp true G1 (TBind TA1) T2 (S n1)
... or at least...
*)
| stp_bindx: forall G1 T1 T2 TA1 TA2 n1 n2,
    stp true ((length G1,T1)::G1) T1 T2 n1 ->
    open (length G1) TA1 = T1 ->
    open (length G1) TA2 = T2 ->
    (* we need exp T1 D here *)
    (* how will this interact with narrowing? *)
    (* exp G1 T1 (TMem TL TU) -> *)
    (* stp true G1 TL TU n2 -> *)
    itp ((length G1,T1)::G1) T1 n2 ->
    stp true G1 (TBind TA1) (TBind TA2) (S (n1+n2))

| stp_transf: forall G1 T1 T2 T3 n1 n2,
    stp true G1 T1 T2 n1 ->
    stp false G1 T2 T3 n2 ->
    stp false G1 T1 T3 (S (n1+n2))

| stp_wrapf: forall G1 T1 T2 n1,
    stp true G1 T1 T2 n1 ->
    stp false G1 T1 T2 (S n1)

(* implementable types *)
with itp: tenv -> ty -> nat -> Prop :=

| itp_top: forall G1 n1,
    itp G1 TTop n1
| itp_bool: forall G1 n1,
    itp G1 TBool n1
(* TODO: we should have another mem case,
   if lower bound is bot, upper bound need
   not be realizable (?) *)
| itp_mem: forall G1 TL TU n1 n2,
(*    stp true G1 TL TU n1 -> (* as it looks now, this may not even be needed !! *) *)
    itp G1 TU n2 ->
    itp G1 (TMem TL TU) (S (n1+n2))
| itp_sel: forall G1 TX x n1,
    index x G1 = Some TX ->
    itp G1 TX n1 -> (* could / should we rely on env_itp to provide this? see itp_narrow for additional circularity considerations *)
    itp G1 (TSel x) (S n1)
.

(*

what about intersection types:

STP

  T <: T1,  T <: T2
  -----------------
  T <: T1 /\ T2

  T1 <: T,  T2 wfe
  ----------------
  T1 /\ T2 <: T

  T1 wfe,  T2 <: T
  ----------------
  T1 /\ T2 <: T

EXP

  T1 <x {A: L1..U1},  T2 <x {A: L2..U2}
  ------------------------------------
  T1 /\ T2 <x {A: L1 \/ L2 .. U1 /\ U2 }

  T1 <x {A: L1..U1},  A not in dom(T2)
  ------------------------------------
  T1 /\ T2 <x {A: L1..U1}

  A not in dom(T1),  T2 <x {A: L2..U2}
  ------------------------------------
  T1 /\ T2 <x {A: L2..U2}

Problem case (bad bounds):

  (Int..Int) /\ (String..String)

Expansion:

  (Int \/ String) .. (Int /\ String) <--- not <:

CONSTRAINTS:
  - need good bounds (L < U) for stpd_trans_cross
  - not part of regular stp. needs to come from env
  - but need to be able to do induction on it

HYPOTHESIS:
  - put itp in stp_sel1,sel2 evidence: this mirrors
    env_itp, but enables induction
  - narrow uses env_itp to get new itp (output size
    doesn't matter)

Need itp_exp (example):

  itp (L1..U1) /\ (L2..U2)
  (L1..U1) /\ (L2..U2) <: L..U  [n+1]
--->
  (L1..U1) /\ (L2..U2)  <x  (L1 \/ L2 .. U1 /\ U2)
  (L1 \/ L2  <:  U1 /\ U2)   [n]

  (L1 \/ L2 .. U1 /\ U2)  <:  L..U
  itp U1 /\ U2
*)

Tactic Notation "stp_cases" tactic(first) ident(c) :=
  first;
  [
    Case_aux c "Bot < ?" |
    Case_aux c "? < Top" |
    Case_aux c "Bool < Bool" |
    Case_aux c "Fun < Fun" |
    Case_aux c "Mem < Mem" |
    Case_aux c "? < Sel" |
    Case_aux c "Sel < ?" |
    Case_aux c "Sel < Sel" |
    Case_aux c "Bind < Bind" |
    Case_aux c "Trans" |
    Case_aux c "Wrap"
  ].

Hint Resolve ex_intro.

Hint Constructors stp.
Hint Constructors itp.

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

(*
THIS IS NOW FALSE: lhs must expand.

Example ex1: exists n, stp true nil (TBind TBot) (TBind TTop) n.
Proof.
 eexists. eapply stp_bindx. eapply stp_bot. eauto. (* false - bot doesn't exp! *).
Grab Existential Variables. apply 0.
Qed.
 *)

Example ex2: exists n, stp true nil
   (TBind (TMem TBool TBool))
   (TBind (TMem TBot TTop)) n.
Proof.
  eexists. eapply stp_bindx. eapply stp_mem.  eapply stp_wrapf. eapply stp_bot.
  eapply stp_bool.
  eapply stp_top. compute. eauto. compute. eauto. eauto.
Grab Existential Variables. apply 0. apply 0. apply 0. apply 0. apply 0.
Qed.

Example ex3: exists n, stp true nil
   (TBind (TMem TBool TBool))
   (TBind (TMem (TSelB 0) (TSelB 0))) n. (* can't do much with this *)
Proof.
  eexists. eapply stp_bindx.
  instantiate (3 := (TMem TBool TBool)).
  instantiate (2 := (TMem (TSel 0) (TSel 0))).

  eapply stp_mem. eapply stp_wrapf.
  eapply stp_sel1. compute. eauto. eauto. eapply stp_mem. eauto. eauto. eauto. eauto.
  eapply stp_sel2. compute. eauto. eauto.
  eauto. eauto. eauto. eauto.
Grab Existential Variables. apply 0. apply 0. apply 0. apply 0. apply 0. apply 0. apply 0. apply 0. apply 0. apply 0. apply 0. apply 0. apply 0.
Qed.

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

Definition stpd b G1 T1 T2 := exists n, stp b G1 T1 T2 n.
Definition itpd G1 T1 := exists n, itp G1 T1 n.

Hint Unfold stpd.
Hint Unfold itpd.

Ltac ep := match goal with
             | [ |- stp ?M ?G1 ?T1 ?T2 ?N ] => assert (exists (x:nat), stp M G1 T1 T2 x) as EEX
           end.

Ltac eu := match goal with
             | H: stpd _ _ _ _ |- _ => destruct H
             | H: itpd _ _ |- _ => destruct H
(*             | H: exists n: nat ,  _ |- _  =>
               destruct H as [e P] *)
           end.

Lemma stpd_bot: forall G1 T,
    stpd true G1 TBot T.
Proof. intros. exists 2. eauto. Qed.
Lemma stpd_top: forall G1 T,
    stpd true G1 T TTop.
Proof. intros. exists 0. eauto. Qed.
Lemma stpd_bool: forall G1,
    stpd true G1 TBool TBool.
Proof. intros. exists 0. eauto. Qed.
Lemma stpd_fun: forall m G1 T11 T12 T21 T22,
    stpd false G1 T21 T11 ->
    stpd true G1 T12 T22 ->
    stpd true G1 (TFun m T11 T12) (TFun m T21 T22).
Proof. intros. repeat eu. eauto. Qed.
Lemma stpd_mem: forall G1 T11 T12 T21 T22,
    stpd false G1 T21 T11 ->
    stpd true G1 T11 T12 ->
    stpd true G1 T12 T22 ->
    stpd true G1 (TMem T11 T12) (TMem T21 T22).
Proof. intros. repeat eu. eauto. Qed.
Lemma stpd_sel2: forall x T1 TX G1,
    index x G1 = Some TX ->
    itpd G1 TX ->
    stpd true G1 TX (TMem T1 TTop) ->
    stpd true G1 T1 (TSel x).
Proof. intros. repeat eu. eauto. Qed.
Lemma stpd_sel1:  forall x T2 TX G1,
    index x G1 = Some TX ->
    itpd G1 TX ->
    stpd true G1 TX (TMem TBot T2) ->
    stpd true G1 (TSel x) T2.
Proof. intros. repeat eu. eauto. Qed.
Lemma stpd_selx: forall x G1,
    stpd true G1 (TSel x) (TSel x).
Proof. intros. repeat eu. exists 1. eauto. Qed.
Lemma stpd_bindx: forall G1 T1 T2 TA1 TA2,
    stpd true ((length G1,T1)::G1) T1 T2 ->
    open (length G1) TA1 = T1 ->
    open (length G1) TA2 = T2 ->
    (* exp G1 T1 (TMem TL TU) -> *)
    (* stpd true G1 TL TU -> *)
    itpd ((length G1,T1)::G1) T1 ->
    stpd true G1 (TBind TA1) (TBind TA2).
Proof. intros. repeat eu. eauto. Qed.
Lemma stpd_transf: forall G1 T1 T2 T3,
    stpd true G1 T1 T2 ->
    stpd false G1 T2 T3 ->
    stpd false G1 T1 T3.
Proof. intros. repeat eu. eauto. Qed.
Lemma stpd_wrapf: forall G1 T1 T2,
    stpd true G1 T1 T2 ->
    stpd false G1 T1 T2.
Proof. intros. repeat eu. eauto. Qed.

Ltac index_subst := match goal with
                 | H1: index ?x ?G = ?V1 , H2: index ?x ?G = ?V2 |- _ => rewrite H1 in H2; inversion H2; subst
                 | _ => idtac
               end.

Lemma stp0f_trans: forall n n1 n2 G1 T1 T2 T3,
    stp false G1 T1 T2 n1 ->
    stp false G1 T2 T3 n2 ->
    n1 <= n ->
    stpd false G1 T1 T3.
Proof.
  intros n. induction n.
  - Case "z".
    intros. assert (n1 = 0). omega. subst. inversion H.
  - Case "S n".
    intros. inversion H.
    + eapply stpd_transf. eexists. eapply H2. eapply IHn. eapply H3. eapply H0. omega.
    + eapply stpd_transf. eexists. eapply H2. eexists. eapply H0.
Qed.

(* implementable context *)
Definition env_itp G (n:nat) := forall x T, index x G = Some T -> exists n2, itp G T n2.

(* left:  may use axiom but has size. must shrink *)
(* right: no axiom but can grow *)

Definition trans_env_on G1 n2 :=
  forall m T1 T2 T3,
      stp m G1 T1 T2 n2 ->
      stpd true G1 T2 T3 ->
      stpd true G1 T1 T3.

Hint Unfold trans_env_on.

Definition trans_on n1 n2 :=
  forall G1,
    env_itp G1 n1 ->
    trans_env_on G1 n2.

Hint Unfold trans_on.

Definition trans_up n := forall n1 n2, n1 + n2 <= n ->
                      trans_on n1 n2.
Hint Unfold trans_up.

Lemma trans_le: forall n n1 n2,
                      trans_up n ->
                      n1 + n2 <= n ->
                      trans_on n1 n2
.
Proof. intros. unfold trans_up in H. eapply H. eauto. Qed.

Lemma upd_length_same: forall {X} G x (T:X),
              length G = length (update x T G).
Proof.
  intros X G x T. induction G.
  - simpl. reflexivity.
  - destruct a as [n' Ta]. simpl.
    remember (beq_nat x (length G)).
    destruct b.
    + simpl. reflexivity.
    + simpl. f_equal. apply IHG.
Qed.

Lemma upd_hit: forall {X} G G' x x' (T:X) T',
              index x G = Some T ->
              update x' T' G = G' ->
              beq_nat x x' = true ->
              index x G' = Some T'.
Proof.
  intros X G G' x x' T T' Hi Hu Heq.
  subst. induction G.
  - simpl in Hi. inversion Hi.
  - destruct a as [n' Ta]. simpl in Hi.
    remember (beq_nat x (length G)).
    apply beq_nat_true in Heq.
    destruct b.
    + simpl.
      apply beq_nat_eq in Heqb.
      subst. subst.
      rewrite <- beq_nat_refl.
      simpl.
      rewrite <- beq_nat_refl.
      reflexivity.
    + simpl.
      subst.
      rewrite <- Heqb.
      simpl.
      assert ((length G) = (length (update x' T' G))) as HnG. {
        apply upd_length_same.
      }
      rewrite <- HnG.
      rewrite <- Heqb.
      apply IHG.
      apply Hi.
Qed.

Lemma upd_miss: forall {X} G G' x x' (T:X) T',
              index x G = Some T ->
              update x' T' G = G' ->
              beq_nat x x' = false ->
              index x G' = Some T.
Proof.
  intros X G G' x x' T T' Hi Hu Heq.
  subst. induction G.
  - simpl in Hi. inversion Hi.
  - destruct a as [n' Ta]. simpl in Hi. simpl.
    remember (beq_nat x (length G)).
    destruct b.
    + apply beq_nat_eq in Heqb.
      subst.
      rewrite beq_nat_sym. rewrite Heq.
      simpl.
      assert ((length G) = (length (update x' T' G))) as HnG. {
        apply upd_length_same.
      }
      rewrite <- HnG.
      rewrite <- beq_nat_refl.
      apply Hi.
    + remember (beq_nat x' (length G)) as b'.
      destruct b'.
      * simpl.
        rewrite <- Heqb.
        apply Hi.
      * simpl.
        assert ((length G) = (length (update x' T' G))) as HnG. {
          apply upd_length_same.
        }
        rewrite <- HnG.
        rewrite <- Heqb.
        apply IHG.
        apply Hi.
Qed.

Lemma index_max : forall X vs n (T: X),
                       index 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 E.
  SCase "hit".
  rewrite E in H1. inversion H1. subst.
  eapply beq_nat_true in E.
  unfold length. unfold length in E. rewrite E. eauto.
  SCase "miss".
  rewrite E in H1.
  assert (n < length vs). eapply IHvs. apply H1.
  compute. eauto.
Qed.

Lemma index_extend : forall X vs n a (T: X),
                       index n vs = Some T ->
                       index n (a::vs) = Some T.

Proof.
  intros.
  assert (n < length vs). eapply index_max. eauto.
  assert (n <> length vs). omega.
  assert (beq_nat n (length vs) = false) as E. eapply beq_nat_false_iff; eauto.
  unfold index. unfold index in H. rewrite H. rewrite E. destruct a. reflexivity.
Qed.

Lemma update_extend: forall X (T1: X) (TX1: X) G1 G1' x a,
  index x G1 = Some T1 ->
  update x TX1 G1 = G1' ->
  update x TX1 (a::G1) = (a::G1').
Proof.
  intros X T1 TX1 G1 G1' x a Hi Hu.
  assert (x < length G1) as Hlt. {
    eapply index_max.
    eauto.
  }
  assert (x <> length G1) as Hneq by omega.
  assert (beq_nat x (length G1) = false) as E. {
    eapply beq_nat_false_iff; eauto.
  }
  destruct a as [n' Ta].
  simpl. rewrite E. rewrite Hu. reflexivity.
Qed.

Lemma update_pres_len: forall X (TX1: X) G1 G1' x,
  update x TX1 G1 = G1' ->
  length G1 = length G1'.
Proof.
  intros X TX1 G1 G1' x H. subst. apply upd_length_same.
Qed.

Lemma stp_extend : forall m G1 T1 T2 x v n,
                       stp m G1 T1 T2 n ->
                       stp m ((x,v)::G1) T1 T2 n.
Proof. admit. (*intros. destruct H. eexists. eapply stp_extend1. apply H.*) Qed.

Lemma itp_extend: forall G T n x v,
                         itp G T n ->
                         itp ((x,v)::G) T n.
Proof.
  intros. induction H; eauto using index_extend.
Qed.

(* currently n,n2 unrelated, but may change. keep in sync with env_itp definition *)
Lemma env_itp_extend : forall G n x v n2,
                       env_itp G n ->
                       itp ((x,v)::G) v n2 ->
                       env_itp ((x,v)::G) n.
Proof.
  intros. unfold env_itp in H. unfold env_itp. intros.
  case_eq (beq_nat x0 (length G)); intros.
  - assert (x0 = (length G)). eapply beq_nat_true_iff; eauto.
    subst x0. unfold index in H1. rewrite H2 in H1. inversion H1. subst v.
    eexists. eapply H0.
  - assert (x0 <> (length G)). eapply beq_nat_false_iff; eauto.
    assert (x0 < length ((x,v)::G)). eapply index_max; eauto.

    unfold index in H1. rewrite H2 in H1.
    eapply H in H1. destruct H1. eexists. eapply itp_extend. apply H1.
Qed.

Lemma itp_narrow: forall G1 G1' T1 x TX1 TX2,
    itpd G1 T1 ->
    index x G1 = Some TX2 ->
    update x TX1 G1 = G1' ->
    (* env_itp G1 nG ->  right now not needed at all! *)
    itpd G1' TX1 ->
    itpd G1' T1.
Proof.
  intros.
  destruct H. destruct H2.
  induction H.
  + SCase "top". exists 0. eauto.
  + SCase "bool". exists 0. eauto.
  + SCase "mem".
    assert (exists nx : nat, itp G1' TU nx) as IH. eapply IHitp; eauto.
    destruct IH.
    eexists. eapply itp_mem. eauto.
  + SCase "sel".
    assert (exists nx : nat, itp G1' TX nx) as IH. eapply IHitp; eauto.
    destruct IH.
    case_eq (beq_nat x0 x); intros E.
    * assert (x0 = x) as EX. eapply beq_nat_true_iff; eauto.
      subst. index_subst. index_subst.
      eexists. eapply itp_sel. eapply upd_hit. eauto. eauto. eauto. eauto.
    * assert (x0 <> x) as EX. eapply beq_nat_false_iff; eauto.
      subst.
      eexists. eapply itp_sel. eapply upd_miss. eauto. eauto. eauto. eauto.

Grab Existential Variables. apply 0.
Qed.

Lemma stp_narrow: forall n, forall m G1 T1 T2 n1 n0,
  stp m G1 T1 T2 n0 ->
  n0 <= n ->
  forall x TX1 TX2 G1' nG nI,

    index x G1 = Some TX2 ->
    update x TX1 G1 = G1' ->
    stp true G1' TX1 TX2 n1 ->
    env_itp G1' nG ->
    itp G1' TX1 nI ->
    trans_on nG n1 ->

    stpd m G1' T1 T2.
Proof.
  intros n.
  induction n.
  (* z *)
  intros m G1 T1 T2 n1 n0 H NE.
  inversion H; intros; try solve [ omega ].
    eapply stpd_bot.
    eapply stpd_top.
    eapply stpd_bool.
  (* s n *)
  intros m G1 T1 T2 n1 n0 H NE.
  inversion H; intros.
  - Case "Bot".
    intros. eapply stpd_bot.
  - Case "Top".
    intros. eapply stpd_top.
  - Case "Bool".
    intros. eapply stpd_bool.
  - Case "Fun".
    intros. eapply stpd_fun. eapply IHn; eauto. omega. eapply IHn; eauto. omega.
  - Case "Mem".
    intros. eapply stpd_mem. eapply IHn; eauto. omega. eapply IHn; eauto. omega. eapply IHn; eauto. omega.
  - Case "Sel2". intros.
    { case_eq (beq_nat x x0); intros E.
      assert (env_itp G1' nG). auto.
      (* hit updated binding *)
      + assert (x = x0) as EX. eapply beq_nat_true_iff; eauto. subst. index_subst. index_subst.
        eapply stpd_sel2. eapply upd_hit; eauto.
        (* already have itp *)
        eauto.
        (* trans, and narrow by induction *)
        eapply H13. eapply H11. eapply H10. eapply IHn; eauto. omega.
      (* other binding *)
      + assert (x <> x0) as EX. eapply beq_nat_false_iff; eauto.
        eapply stpd_sel2. eapply upd_miss; eauto.
        (* new itp from env_itp: alt 1 -- call env_itp *)
        (* eapply H5. eapply upd_miss; eauto. *)
        (* alt 2 -- call itp_narrow *)
        eapply itp_narrow; eauto.
        (* narrow stp by induction *)
        eapply IHn; eauto. omega.
    }
  - Case "Sel1". intros.
    { case_eq (beq_nat x x0); intros E.
      assert (env_itp G1' nG). auto.
      (* hit updated binding *)
      + assert (x = x0) as EX. eapply beq_nat_true_iff; eauto. subst. index_subst. index_subst.
        eapply stpd_sel1. eapply upd_hit; eauto.
        (* already have itp *)
        eauto.
        (* trans, and narrow by induction *)
        eapply H13. eapply H11. eapply H10. eapply IHn; eauto. omega.
      (* other binding *)
      + assert (x <> x0) as EX. eapply beq_nat_false_iff; eauto.
        eapply stpd_sel1. eapply upd_miss; eauto.
        (* new itp: see above for alternatives *)
        eapply itp_narrow; eauto.
        (* narrow stp by induction *)
        eapply IHn; eauto. omega.
    }
  - Case "Selx". eapply stpd_selx.
  - Case "Bindx".
    (*
       Note: there is a choice to make whether itp_narrow can use
       the extended G1 (i.e. members can refer to this) or
       whether it can rely on env_itp. Both together seems tricky,
       because env_itp_extend would need result of itp_narrow
       (and vice versa).

       All upper bounds must be realizable (deep, via itp).
    *)

    assert (length G1 = length G1'). { eapply update_pres_len; eauto. }
    remember (length G1) as L. clear HeqL. subst L.

    assert (itp ((length G1', T0)::G1) T0 n3). { eauto. } (* already have it! *)
    (* will do induction with extended env. need to prove T1 realizable in G1' *)
    assert (itpd ((length G1', T0)::G1') T0) as IE. {
      eapply itp_narrow.
      eexists. eapply H3.
      eapply index_extend; eauto.
      eapply update_extend; eauto.
      eexists. eapply itp_extend; eauto.
    }
    destruct IE.

    eapply stpd_bindx. {
      eapply IHn. eauto. omega.
      eapply index_extend; eauto.
      eapply update_extend; eauto.
      eapply stp_extend; eauto.

      eapply env_itp_extend. eauto. eauto.
      eapply itp_extend. eauto. eauto.
    }
    eauto.
    eauto.
    eauto.

  - Case "Trans". eapply stpd_transf. eapply IHn; eauto. omega. eapply IHn; eauto. omega.
  - Case "Wrap". eapply stpd_wrapf. eapply IHn; eauto. omega.
Qed.

(* ---------- EXPANSION / MEMBERSHIP ---------- *)
(* In the current version, expansion is an implementation
   detail. We just use it to derive some helper lemmas
   to show that implementable types have good bounds.
*)

(* expansion / membership *)
(* this is the precise version! no slack in lookup *)
(* TODO: need the name for bind? *)
Inductive exp : tenv -> ty -> ty -> Prop :=
(*
| exp_bot: forall G1,
    exp G1 TBot (TMem TTop TBot)  (* causes trouble in inv_mem: need to build stp deriv with smaller n *)
*)
| exp_mem: forall G1 T1 T2,
    exp G1 (TMem T1 T2) (TMem T1 T2)
| exp_sel: forall G1 x T T2 T3 T4 T5,
    index x G1 = Some T ->
    exp G1 T (TMem T2 T3) ->
    exp G1 T3 (TMem T4 T5) ->
    exp G1 (TSel x) (TMem T4 T5)
.

(*
NOT NEEDED (apparently)
Lemma exp_unique: forall G1 T1 TA1 TA2 TA1L TA2L,
  exp G1 T1 (TMem TA1L TA1) ->
  exp G1 T1 (TMem TA2L TA2) ->
  TA1 = TA2.
Proof.  Qed.
*)

(* key lemma that relates exp and stp. result has bounded size. *)
Lemma stpd_inv_mem: forall n n1 G1,

  forall TA1 TA2 TA1L TA2L T1,
  exp G1 T1 (TMem TA1L TA1) ->
  stp true G1 T1 (TMem TA2L TA2) n1 ->
  n1 <= n ->
  exists n3, stp true G1 (TMem TA1L TA1) (TMem TA2L TA2) n3 /\ n3 <= n1. (* should be semantic eq! *)
Proof.
  intros n1. induction n1.
  (*z*) intros. inversion H0; subst; inversion H1; subst; try omega. try inversion H.
  (* s n *)
  intros. inversion H.
(*  - Case "bot". subst. exists 0. split. eapply stp_mem. eauto. eauto. inversion H0.  subst. omega. *)
  - Case "mem". subst. exists n0. auto. (*inversion H0. subst. exists n3. split. eauto. omega. *)
  - Case "sel".
    subst.
    inversion H0.
    repeat index_subst. clear H4.

    assert (exists n0 : nat, stp true G1 (TMem T2 T3) (TMem TBot (TMem TA2L TA2)) n0 /\ n0 <= n2) as S1.
    eapply (IHn1 n2). apply H7. apply H6. omega.

    destruct S1 as [? [S1 ?]]. inversion S1. subst.

    assert (exists n0 : nat, stp true G1 (TMem TA1L TA1) (TMem TA2L TA2) n0 /\ n0 <= n5) as S2.
    eapply (IHn1 n5). apply H8. apply H16. omega.

    destruct S2 as [? [S2 ?]].

    eexists. split. apply S2. omega.
Qed.

Definition env_good_bounds G1 :=
  forall TX T2 T3 x,
    index x G1 = Some TX ->
    exp G1 TX (TMem T2 T3) ->
    exists n2, stp true G1 T2 T3 n2.

(*
could go this route, if itp contains L<U evidence,
but currently not needed.

Lemma env_itp_gb: forall G1 n1,
  env_itp G1 n1 ->
  env_good_bounds G1.
Proof. Qed.
*)

(* dual case *)
Lemma stpd_build_mem: forall n1 n2 G1,
  forall TA1 TA2 TA1L TA2L T1,
    exp G1 T1 (TMem TA1L TA1) ->
    env_good_bounds G1 ->
    env_itp G1 n2 -> (* to obtain itp evidence for sel1 result *)
  stp true G1 (TMem TA1L TA1) (TMem TA2L TA2) n1 ->
  exists n3, stp true G1 T1 (TMem TA2L TA2) n3.
Proof.
  (* now taking 'good bounds' evidence as input *)

  intros.
  generalize dependent n1.
  generalize dependent TA2.
  generalize dependent TA2L.
  induction H.
  - Case "mem".
    subst. eexists. eauto.
  - Case "sel".
    intros. subst.
    (* inversion H2. subst. index_subst. subst. *)
    assert (exists n3, stp true G1 T3 (TMem TA2L TA2) n3) as IX2. {
      eapply IHexp2. eauto. eauto. eauto.
    }
    destruct IX2 as [n4 IX2].
    (* here we need T2 < T3 to construct stp_mem *)
    (* current stragety is to get it from env_good_bounds *)
    assert (exists n2, stp true G1 T2 T3 n2) as IY. eauto.
    destruct IY as [? IY].
    assert (exists n3, stp true G1 T (TMem TBot (TMem TA2L TA2)) n3) as IX. {
      eapply IHexp1. eauto. eauto. eapply stp_mem. eapply stp_wrapf. eapply stp_bot.
      apply IY. apply IX2.
    }
    destruct IX.
    assert (itpd G1 T) as IZ. { eauto. (* from env_itp *) }
    destruct IZ.
    subst. eexists. eapply stp_sel1. eauto. eauto. eauto.
    Grab Existential Variables. apply 0.
Qed.

(* trans helpers -- these are based on exp only and currently not used *)

Lemma stpde_trans_lo: forall G1 T1 T2 TX TXL TXU nG,
  stpd true G1 T1 T2 ->
  stpd true G1 TX (TMem T2 TTop) ->
  exp G1 TX (TMem TXL TXU) ->
  env_itp G1 nG ->
  env_good_bounds G1 ->
  stpd true G1 TX (TMem T1 TTop).
Proof.
  intros. repeat eu.
  assert (exists nx, stp true G1 (TMem TXL TXU) (TMem T2 TTop) nx /\ nx <= x) as E. eapply (stpd_inv_mem x). eauto. eauto. omega.
  destruct E as [nx [ST X]].
  inversion ST. subst.

  eapply stpd_build_mem. eauto. eauto. eauto. eapply stp_mem. eapply stp_transf. eauto. eauto. eauto. eauto.
Qed.

Lemma stpde_trans_hi: forall G1 T1 T2 TX n1 nG TXL TXU,
  stpd true G1 T1 T2 ->
  stp true G1 TX (TMem TBot T1) n1 ->
  exp G1 TX (TMem TXL TXU) ->
  env_itp G1 nG ->
  env_good_bounds G1 ->
  trans_up (nG + n1) ->
  stpd true G1 TX (TMem TBot T2).
Proof.
  intros. repeat eu.
  assert (exists nx, stp true G1 (TMem TXL TXU) (TMem TBot T1) nx /\ nx <= n1) as E. eapply (stpd_inv_mem n1). eauto. eauto. omega.
  destruct E as [nx [ST X]].
  inversion ST. subst.

  assert (trans_on nG n3) as IH. { eapply trans_le; eauto. omega. }
  assert (stpd true G1 TXU T2) as ST1. { eapply IH. eauto. eauto. eauto. }
  destruct ST1.
  eapply stpd_build_mem. eauto. eauto. eauto. eapply stp_mem. eauto. eauto. eauto.
Qed.

(* need to invert mem. requires proper realizability evidence *)
Lemma stpde_trans_cross: forall G1 TX T1 T2 TXL TXU n1 n2 nG n,
                          (* trans_on *)
  stp true G1 TX (TMem T1 TTop) n1 ->
  stpd true G1 TX (TMem TBot T2) ->
  exp G1 TX (TMem TXL TXU) ->
  stp true G1 TXL TXU n2 ->
  env_itp G1 nG ->
  trans_up n ->
  nG + n2 <= n ->
  nG + n1 <= n ->
  nG <= n ->
  stpd true G1 T1 T2.
Proof.
  intros. eu.
  assert (exists n3, stp true G1 (TMem TXL TXU) (TMem T1 TTop) n3 /\ n3 <= n1) as SM1. eapply (stpd_inv_mem n1). eauto. eauto. omega.
  assert (exists n3, stp true G1 (TMem TXL TXU) (TMem TBot T2) n3 /\ n3 <= x) as SM2. eapply (stpd_inv_mem x). eauto. eauto. omega.
  destruct SM1 as [n3 [SM1 E3]].
  destruct SM2 as [n4 [SM2 E4]].
  inversion SM1. inversion SM2.
  subst. clear SM1 SM2.

  assert (trans_on nG n0) as IH0. { eapply trans_le; eauto. omega. }
  assert (trans_on nG n2) as IH1. { eapply trans_le; eauto. }
  eapply IH0. eauto. eauto. eapply IH1. eauto. eauto. eauto.
Qed.

(* ----- end expansion  ----- *)

(* -- trans helpers: based on imp *)

(* if a type is realizable, it expands *)
Lemma itp_exp_internal: forall n G1, forall T1 TL TU n1 n3,
  n1 <= n ->
  itp G1 T1 n1 ->
  stp true G1 T1 (TMem TL TU) n3 ->
  exists TL1 TU1 n4 n5 n6,
    exp G1 T1 (TMem TL1 TU1) /\
    stp true G1 TL1 TU1 n5 /\
    stp true G1 (TMem TL1 TU1) (TMem TL TU) n6 /\
    itp G1 TU1 n4 /\
    n4 <= n /\
    n5 <= n3 /\
    n6 <= n3.
Proof.
  intros n1 G1.
  induction n1.
  Case "z". intros. inversion H; subst. inversion H0; subst; inversion H1. subst.
  Case "S n". intros. inversion H0; subst; inversion H1. subst.
  - SCase "mem".
    repeat eexists. eapply exp_mem. eauto. eauto. eauto. omega. omega. omega.
  - SCase "sel".
    index_subst.

    (* first half *)
    assert (n2 <= n1) as E. omega.
    assert (exists TL1 TU1 n4 n5 n6,
              exp G1 TX0 (TMem TL1 TU1) /\
              stp true G1 TL1 TU1 n5 /\
              stp true G1 (TMem TL1 TU1) (TMem TBot (TMem TL TU)) n6 /\
              itp G1 TU1 n4 /\
              n4 <= n1 /\
              n5 <= n0 /\
              n6 <= n0
           ) as IH. { eapply IHn1. apply E. eauto. eauto. }
    repeat destruct IH as [? IH].

    (* obtain stp for second half input *)
    assert (exists n, stp true G1 (TMem x0 x1) (TMem TBot (TMem TL TU)) n /\ n <= n0) as IX.
    { eauto. }
    repeat destruct IX as [? IX]. inversion H13. subst.

    assert (exists TL1 TU1 n4' n5' n6',
              exp G1 x1 (TMem TL1 TU1) /\
              stp true G1 TL1 TU1 n5' /\
              stp true G1 (TMem TL1 TU1) (TMem TL TU) n6' /\
              itp G1 TU1 n4' /\
              n4' <= n1 /\
              n5' <= n6 /\
              n6' <= n6
           ) as IH2. { eapply IHn1. apply H11. eauto. eauto. }
    repeat destruct IH2 as [? IH2].
    repeat eexists. index_subst.
    eapply exp_sel. eauto. eauto. eauto. eauto. eauto. eauto. omega. omega. omega.
Qed.

Lemma itp_exp: forall G1 T1 TL TU n1 n2,
  itp G1 T1 n1 ->
  stp true G1 T1 (TMem TL TU) n2 ->
  exists TL1 TU1, exp G1 T1 (TMem TL1 TU1).
Proof.
  intros.
  assert (exists TL1 TU1 n4 n5 n6,
            exp G1 T1 (TMem TL1 TU1) /\
            stp true G1 TL1 TU1 n5 /\
            stp true G1 (TMem TL1 TU1) (TMem TL TU) n6 /\
            itp G1 TU1 n4 /\
            n4 <= n1 /\
            n5 <= n2 /\
            n6 <= n2
         ) as HH. eapply itp_exp_internal; eauto.
  repeat destruct HH as [? HH].
  repeat eexists. eauto.
Qed.

(* need to invert mem. requires proper realizability evidence *)
Lemma stpd_trans_cross: forall G1 TX T1 T2 n1 n2 nG n,
  stp true G1 TX (TMem T1 TTop) n1 ->
  stpd true G1 TX (TMem TBot T2) ->
  itp G1 TX n2 ->
  env_itp G1 nG ->
  nG + n1 <= n ->
  nG <= n ->
  trans_up n ->
  stpd true G1 T1 T2.
Proof.
  intros. eu.
  assert (exists TL1 TU1, exists TL TU n4 n5 n6,
            exp G1 TX (TMem TL TU) /\
            stp true G1 TL TU n5 /\
            stp true G1 (TMem TL TU) (TMem TL1 TU1) n6 /\
            itp G1 TU n4 /\
            n4 <= n2 /\
            n5 <= n1 /\
            n6 <= n1
         ) as HH. { eexists. eexists. eapply itp_exp_internal; eauto. }
  repeat destruct HH as [? HH].

  eapply stpde_trans_cross; eauto. omega.
Qed.

Lemma stpd_trans_hi: forall G1 T1 T2 TX n1 nG n2,
  stpd true G1 T1 T2 ->
  stp true G1 TX (TMem TBot T1) n1 ->
  itp G1 TX n2 ->
  env_itp G1 nG ->
  trans_up (nG + n1) ->
  stpd true G1 TX (TMem TBot T2).
Proof.
  intros. eu.
  generalize dependent T1.
  generalize dependent T2.
  generalize dependent x.
  generalize dependent n1.
  induction H1; intros.
  - inversion H0.
  - inversion H0.
  - Case "mem".
    inversion H0. subst.
    assert (trans_on nG n5) as IH. { eapply trans_le; eauto. omega. }

    eapply stpd_mem. eauto. eauto. eapply IH. eauto. eauto. eauto.
  - Case "sel".
    inversion H4. subst. index_subst.
    assert (nG + n2 <= nG + (S n2)). omega.
    assert (trans_up (nG + n2)) as IH. { unfold trans_up. intros. eapply trans_le; eauto. omega. }
    eapply stpd_sel1. eauto. eauto.
    + eapply IHitp. eauto. eauto.
      (* arg: (TMem TBot T1) <: (TMem TBot T2) *)
      eapply stp_mem. eapply stp_wrapf. eapply stp_bot. eapply stp_bot. eapply H0. eapply H8.
Grab Existential Variables. apply 0. apply 0.
Qed.

Inductive trivial_stp: ty -> ty -> Prop :=
| trivial_mem: forall T1 T2,
    trivial_stp (TMem T1 TTop) (TMem T2 TTop)
| trivial_nest: forall T1 T2,
    trivial_stp T1 T2 ->
    trivial_stp (TMem TBot T1) (TMem TBot T2).

(* TODO: should be able to do this without itp *)
(* by induction on TX < T1 *)
Lemma stpd_trans_triv: forall G1 T1 T2 TX n2,
  trivial_stp T1 T2 ->
  stpd true G1 T1 T2 ->
  stpd true G1 TX T1 ->
  itp G1 TX n2 ->
  stpd true G1 TX T2.
Proof.
  intros. eu.
  generalize dependent T1.
  generalize dependent T2.
  generalize dependent x.
  induction H2; intros.
  - inversion H; subst; inversion H1.
  - inversion H; subst; inversion H1.
  - Case "mem".
    (* remember (TMem TL TU) as TX.
    generalize dependent TX. *)
    induction H.
    + SCase "trivial mem".
      inversion H0. inversion H1. subst. inversion H. subst.
      eapply stpd_mem. eapply stp0f_trans. eauto. eauto. eauto. eauto. eauto.
    + SCase "trivial nest".
      inversion H0. inversion H1. subst. inversion H3. subst.
      eapply stpd_mem. eauto. eauto. eapply IHitp. eauto. eauto. eauto.
  - Case "sel".
    inversion H0.
    + SCase "trivial mem". subst.
      inversion H3. subst. index_subst.
      eapply stpd_sel1. eauto. eauto. eapply IHitp. eauto. eapply trivial_nest. eauto.
      eapply stpd_mem. eauto. eauto. eauto. eauto.
    + SCase "trivial nest". subst.
      inversion H3. subst. index_subst.
      eapply stpd_sel1. eauto. eauto. eapply IHitp. eauto. eapply trivial_nest. eauto.
      eapply stpd_mem. eauto. eauto. eauto. eauto.
Grab Existential Variables. apply 0. apply 0. apply 0. apply 0.
Qed.

Lemma stpd_trans_lo: forall G1 T1 T2 TX n2,
  stpd true G1 T1 T2 ->
  stpd true G1 TX (TMem T2 TTop) ->
  itp G1 TX n2 ->
  stpd true G1 TX (TMem T1 TTop).
Proof.
  intros. eapply stpd_trans_triv. eapply trivial_mem.
  eapply stpd_mem. eapply stpd_wrapf. eauto. eauto. eauto. eauto. eauto.
  Grab Existential Variables. apply 0. apply 0.
Qed.

(* proper trans lemma *)
Lemma stp1_trans: forall n, trans_up n.
Proof.
  intros n. induction n. {
    Case "z".
    unfold trans_up. intros nG n1 NE1 G1 IMP  b T1 T2 T3 S12 S23.
    destruct S23 as [? S23].
    stp_cases(inversion S12) SCase; subst;
    try (assert (1=0) as HX; omega; inversion HX). (* most cases cannot happen *)
    - SCase "Bot < ?". eapply stpd_bot.
    - SCase "? < Top". inversion S23; subst.
      + SSCase "Top". eauto.
      + SSCase "Sel2".
        assert (index x0 G1 = Some TX). eauto.
        eapply IMP in H. destruct H. subst.
        eapply stpd_sel2. eauto. eauto. eapply stpd_trans_lo; eauto.
    - SCase "Bool < Bool". eauto.
  }

  Case "S n".
  unfold trans_up. intros nG n1 NE1 G1 IMP  b T1 T2 T3 S12 S23.
  destruct S23 as [n2 S23].

  stp_cases(inversion S12) SCase.
  - SCase "Bot < ?". eapply stpd_bot.
  - SCase "? < Top". subst. inversion S23; subst.
    + SSCase "Top". eapply stpd_top.
    + SSCase "Sel2".
      assert (exists nI, itp G1 TX nI) as E. { eapply IMP. eauto. } destruct E as [? E].
      assert (itp G1 TX x0) as E2. eauto.
      eapply itp_exp in E; eauto.
      eapply stpd_sel2; eauto. eauto. eapply stpd_trans_lo; eauto.
  - SCase "Bool < Bool". inversion S23; subst; try solve by inversion.
    + SSCase "Top". eauto.
    + SSCase "Bool". eapply stpd_bool; eauto.
    + SSCase "Sel2". eapply stpd_sel2. eauto. eauto. eexists. eapply H6.
  - SCase "Fun < Fun". inversion S23; subst; try solve by inversion.
    + SSCase "Top". eapply stpd_top.
    + SSCase "Fun". inversion H10. subst.
      eapply stpd_fun.
      * eapply stp0f_trans; eauto.
      * assert (trans_on nG n3) as IH.
        { eapply trans_le; eauto. omega. }
        eapply IH; eauto.
    + SSCase "Sel2".
      assert (exists nI, itp G1 TX nI) as E. { eapply IMP. eauto. } destruct E as [? E].
      assert (itp G1 TX x0) as E2. eauto.
      eapply itp_exp in E; eauto.
      eapply stpd_sel2. eauto. eauto. eapply stpd_trans_lo; eauto.
  - SCase "Mem < Mem". inversion S23; subst; try solve by inversion.
    + SSCase "Top". eapply stpd_top.
    + SSCase "Mem". inversion H12. subst.
      eapply stpd_mem.
      * eapply stp0f_trans; eauto.
      * eauto.
      * assert (trans_on nG n4) as IH.
        { eapply trans_le; eauto. omega. }
        eapply IH; eauto.
    + SSCase "Sel2".
      assert (exists nI, itp G1 TX nI) as E. { eapply IMP. eauto. } destruct E as [? E].
      assert (itp G1 TX x0) as E2. eauto.
      eapply itp_exp in E; eauto.
      eapply stpd_sel2. eauto. eauto. eapply stpd_trans_lo; eauto.
  - SCase "? < Sel". inversion S23; subst; try solve by inversion.
    + SSCase "Top". eapply stpd_top.
    + SSCase "Sel2".
      assert (exists nI, itp G1 TX0 nI) as E. { eapply IMP. eauto. } destruct E as [? E].
      assert (itp G1 TX0 x1) as E2. eauto.
      eapply itp_exp in E; eauto.
      eapply stpd_sel2. eauto. eauto. eapply stpd_trans_lo; eauto.
    + SSCase "Sel1". (* interesting case *)
      index_subst.
      assert (exists nI, itp G1 TX nI) as E. { eapply IMP. eauto. } destruct E as [? E].
      assert (itp G1 TX x1) as E2. eauto.
      eapply itp_exp in E; eauto.
      inversion H12. subst. index_subst. eauto. eapply stpd_trans_cross; eauto. omega.
      assert (trans_up (nG+n0)) as IH.
      { unfold trans_up. intros. apply IHn. omega. }
      apply IH.
    + SSCase "Selx". inversion H9. index_subst. subst. index_subst. subst.
      eapply stpd_sel2. eauto. eauto. eauto.
  - SCase "Sel < ?".
      assert (trans_up (nG+n0)) as IH.
      { unfold trans_up. intros. eapply IHn. omega. }
      assert (exists nI, itp G1 TX nI) as E. { eapply IMP. eauto. } destruct E as [? E].
      assert (itp G1 TX x0) as E2. eauto.
      eapply itp_exp in E; eauto.
      eapply stpd_sel1. eauto. eauto. eapply stpd_trans_hi; eauto.
  - SCase "Sel < Sel". inversion S23; subst; try solve by inversion.
    + SSCase "Top". eapply stpd_top.
    + SSCase "Sel2".
       assert (exists nI, itp G1 TX nI) as E. { eapply IMP. eauto. } destruct E as [? E].
       assert (itp G1 TX x1) as E2. eauto.
       eapply itp_exp in E; eauto.
       (* eapply stpd_sel2. eauto. eapply stpd_trans_lo; eauto. *)
     + SSCase "Sel1". inversion H9. index_subst. subst. index_subst. subst.
       eapply stpd_sel1. eauto. eauto. eauto.
     + SSCase "Selx". inversion H6. subst. repeat index_subst.
       eapply stpd_selx; eauto.
  - SCase "Bind < Bind". inversion S23; subst; try solve by inversion.
    + SSCase "Top". eapply stpd_top.
    + SSCase "Sel2".
      assert (exists nI, itp G1 TX nI) as E. { eapply IMP. eauto. } destruct E as [? E].
      assert (itp G1 TX x0) as E2. eauto.
      eapply itp_exp in E; eauto.
      eapply stpd_sel2. eauto. eauto. eapply stpd_trans_lo; eauto.
    + SSCase "Bind".
      inversion H14. subst.
      assert (trans_up (nG+n0)) as IH.
      { unfold trans_up. intros. eapply IHn. omega. }
      (* realizable in old env *)
      (* assert (itp G1 (open (length G1) TA2) n5). auto. *)
      (* realizable in new env *)
      (* assert (itp G1 (open (length G1) TA1) n3). auto. *)
      (* first narrow, then trans *)
      assert (stpd true ((length G1, open (length G1) TA1) :: G1)
                   (open (length G1) TA2) (open (length G1) TA3)) as NRW.
      {
        assert (beq_nat (length G1) (length G1) = true) as E.
        { eapply beq_nat_true_iff. eauto. }
        inversion H14. subst.
        eapply stp_narrow. eauto. eauto.
        instantiate (2 := length G1). unfold index. rewrite E. eauto.
        instantiate (1 := open (length G1) TA1). unfold update. rewrite E. eauto.
        eauto.
        eapply env_itp_extend. eauto. eauto.
        eauto.
        eauto.
      }
      eapply stpd_bindx. eapply IH.
      eauto.
      eapply env_itp_extend. eauto. eapply H2.
      eauto.
      eauto.
      eauto.
      eauto.
      eauto.
  - SCase "Trans". subst.
    assert (trans_on nG n3) as IH2.
    { eapply trans_le; eauto. omega. }
    assert (trans_on nG n0) as IH1.
    { eapply trans_le; eauto. omega. }
    assert (stpd true G1 T4 T3) as S123.
    { eapply IH2; eauto. }
    destruct S123.
    eapply IH1; eauto.
  - SCase "Wrap". subst.
    assert (trans_on nG n0) as IH.
    { eapply trans_le; eauto. omega. }
    eapply IH; eauto.
Qed.

End DOT.


(* Copyright (c) 2014, Robert Dockins *)

Require Import basics.
Require Import preord.
Require Import categories.
Require Import sets.
Require Import finsets.
Require Import esets.
Require Import directed.

Delimit Scope cpo_scope with cpo.
Open Scope cpo_scope.

Definition continuous (CL:color) (A B:preord) (f:A → B) :=
  forall lub (XS:cl_eset CL A),
    least_upper_bound lub XS ->
    least_upper_bound (f lub) (image f XS).
Arguments continuous CL [A B] f.

Lemma continuous_sequence CL (A B C:preord)
  (g:B → C) (f:A → B) :
  continuous CL g -> continuous CL f -> continuous CL (g ∘ f).
Proof.
  repeat intro.
  cut (least_upper_bound (g (f lub)) (image g (image f XS))).
  rewrite image_compose. auto.
  apply H. apply H0. auto.
Qed.

Lemma continuous_equiv CL (A B:preord) (f f':A → B) :
  f ≈ f' -> continuous CL f -> continuous CL f'.
Proof.
  unfold continuous. intros.
  eapply least_upper_bound_morphism.
  3: apply H0.
  apply H. apply image_morphism.
  split; intro x; destruct (H x); auto.
  reflexivity. auto.
Qed.

Lemma continuous_pair CL (C A B:preord) (f:C → A) (g:C → B) :
  continuous CL f -> continuous CL g -> continuous CL 〈f, g〉.
Proof.
  repeat intro. simpl.
  destruct (H lub XS); auto.
  destruct (H0 lub XS); auto.
  split. red; intros.
  apply image_axiom2 in H6. destruct H6 as [c [??]].
  simpl in H7. rewrite H7. split; simpl.
  apply Preord.axiom. apply H1. auto.
  apply Preord.axiom. apply H1. auto.
  intros. destruct b. split; simpl.
  apply H3. red; intros.
  apply image_axiom2 in H7. destruct H7 as [q [??]].
  rewrite H8.
  cut ((f q, g q) ≤ (c,c0)).
  intros [??]; auto.
  apply H6.
  apply image_axiom1'. exists q. split; auto.
  apply H5. red; intros.
  apply image_axiom2 in H7. destruct H7 as [q [??]].
  rewrite H8.
  cut ((f q, g q) ≤ (c,c0)).
  intros [??]; auto.
  apply H6.
  apply image_axiom1'. exists q. split; auto.
Qed.

Lemma continuous_pi1 CL (A B:preord) :
  @continuous CL (A×B) A π₁.
Proof.
  repeat intro.
  split; repeat intro.
  apply image_axiom2 in H0. destruct H0 as [q [??]].
  rewrite H1.
  cut (q ≤ lub).
  intros [??]; auto.
  apply H. auto.
  destruct H.
  destruct (H1 (b,snd lub)); auto.
  red; intros.
  split; simpl.
  apply H0.
  apply image_axiom1'. exists x; auto.
  cut (x ≤ lub). intros [??]; auto.
  apply H; auto.
Qed.

Lemma continuous_pi2 CL (A B:preord) :
  @continuous CL (A×B) B π₂.
Proof.
  repeat intro.
  split; repeat intro.
  apply image_axiom2 in H0. destruct H0 as [q [??]].
  rewrite H1.
  cut (q ≤ lub).
  intros [??]; auto.
  apply H. auto.
  destruct H.
  destruct (H1 (fst lub,b)); auto.
  red; intros.
  split; simpl.
  cut (x ≤ lub). intros [??]; auto.
  apply H; auto.
  apply H0.
  apply image_axiom1'. exists x; auto.
Qed.

(**  * Complete partial orders

     Here we define the category of colored CPOs.  We will mostly
     be interested in the case where the color is one of the two
     instances of h-directedness; however much of the the theory goes
     through in the more general setting of arbitrary colors.

     A CPO is a preorder where there is a supremum operation for every
     colored set.  CPOs form a category together with the Scott-continuous
     functions, which are monotone and preserve colored suprema.
  *)
Module CPO.
  Record mixin_of (CL:color) (A:preord)
    := Mixin
    { sup : cl_eset CL A -> A
    ; sup_is_ub : forall X, upper_bound (sup X) X
    ; sup_is_least : forall X ub, upper_bound ub X -> sup X ≤ ub
    }.

  Record type (CL:color) := Pack
    { carrier :> Type
    ; ord_mixin : Preord.mixin_of carrier
    ; ord := Preord.Pack carrier ord_mixin
    ; cpo_mixin : mixin_of CL ord
    }.

  Arguments carrier [CL] t.
  Arguments ord [CL] t.
  Arguments cpo_mixin [CL] t.

  Hint Resolve cpo_mixin.
  Canonical Structure ord.

  Definition cpo_eq CL (T:type CL) : Eq.type :=
    Eq.Pack (carrier T) (Eq.mixin (Preord_Eq (ord T))).
  Canonical Structure cpo_eq.

  Definition sup_op CL (t:type CL) : cl_eset CL (ord t) -> ord t :=
    sup CL (ord t) (cpo_mixin t).
  Arguments sup_op [CL] [t] X.

  Notation "∐ XS" := (@sup_op _ _ (XS)%set) : cpo_scope.

  Lemma sup_is_lub : forall CL (A:type CL) (XS:cl_eset CL (ord A)),
    least_upper_bound (∐XS) XS.
  Proof.
    intros. split. apply sup_is_ub. apply sup_is_least.
  Qed.

  Lemma continuous_sup : forall CL (A B:type CL) (f:ord A → ord B),
    continuous CL f <->
    forall (XS:cl_eset CL (ord A)), f (sup_op XS) ≤ sup_op (image f XS).
  Proof.
    intros. split; intros.
    destruct (H (∐XS) XS (sup_is_lub CL A XS)).
    apply H1. red; intros. apply sup_is_ub; auto.

    red; intros; split; repeat intro.
    apply image_axiom2 in H1.
    destruct H1 as [y [??]]. rewrite H2.
    apply Preord.axiom.
    apply H0. auto.
    transitivity (f (∐XS)).
    apply Preord.axiom.
    apply H0. apply sup_is_ub.
    transitivity (∐(image f XS)). apply H.
    apply sup_is_least. auto.
  Qed.

  Lemma continuous_sup' : forall CL (A B:type CL) (f:ord A → ord B),
    continuous CL f <->
    forall (XS:cl_eset CL (ord A)), f (sup_op XS) ≈ sup_op (image f XS).
  Proof.
    intros. rewrite continuous_sup.
    split; intros. split. apply H.
    apply sup_is_least. red; intros.
    apply image_axiom2 in H0. destruct H0 as [y [??]].
    rewrite H1. apply Preord.axiom. apply sup_is_ub. auto.
    apply H.
  Qed.

  Record hom CL (A B:type CL) :=
    Hom
    { map :> ord A -> ord B
    ; mono : forall (a b:carrier A),
               Preord.ord_op (ord A) a b ->
               Preord.ord_op (ord B) (map a) (map b)
    ; cont : continuous CL (Preord.Hom _ _ map mono)
    }.
  Arguments map [CL] [A] [B] h x.
  Arguments mono [CL] [A] [B] h a b _.
  Arguments cont  [CL] [A] [B] h lub XS _.

  Definition ord_hom {CL:color} {A B:type CL} (f:hom CL A B) : Preord.hom (ord A) (ord B) :=
    Preord.Hom _ _ (map f) (mono f).
  Coercion ord_hom : hom >-> Preord.hom.

  Program Definition build_hom {CL:color} (A B:type CL)
    (f:Preord.hom (ord A) (ord B))
    (H:continuous CL f)
    : hom CL A B
    := Hom CL A B (Preord.map _ _ f) _ _.
  Next Obligation.
    simpl; intros. apply Preord.axiom. auto.
  Qed.
  Next Obligation.
    intros. apply H.
  Qed.

  Program Definition ident {CL:color} (X:type CL) :
    hom CL X X := build_hom X X (Preord.ident (ord X)) _.
  Next Obligation.
    repeat intro.
    simpl.
    destruct H; split; repeat intro.
    apply image_axiom2 in H1. destruct H1 as [?[??]].
    simpl in H2. rewrite H2; apply H; auto.
    apply H0. red; intros.
    apply H1.
    apply image_axiom1'. exists x. split; auto.
  Qed.

  Program Definition compose {CL:color} {X Y Z:type CL} (g:hom CL Y Z) (f:hom CL X Y)
    := build_hom X Z (g ∘ f) _.
  Next Obligation.
    repeat intro.
    cut (least_upper_bound (g (f lub)) (image g (image f XS))).
    intros [??]; split; repeat intro.
    apply H0. apply image_axiom2 in H2.
    destruct H2 as [q [??]]. simpl in H3.
    rewrite H3.
    apply image_axiom1'. exists (f q); split; auto.
    apply image_axiom1'. exists q; split; auto.
    apply H1. repeat intro.
    apply H2.
    apply image_axiom2 in H3.
    destruct H3 as [y [??]].
    apply image_axiom2 in H3.
    destruct H3 as [y' [??]].
    apply image_axiom1'. exists y'.
    split; auto.
    simpl.
    rewrite H4.
    rewrite H5. auto.
    apply (cont g). apply (cont f). auto.
  Qed.

  Definition comp_mixin CL := Comp.Mixin (type CL) (hom CL) (@ident CL) (@compose CL).
  Canonical Structure comp CL := Comp.Pack (type CL) (hom CL) (comp_mixin CL).

  Definition app {CL:color} {X Y:type CL} (f:hom CL X Y) (x:X) : Y := map f x.

  Definition hom_order {CL:color} (X Y:type CL) (f g:hom CL X Y) :=
    forall x:X, app f x ≤ app g x.

  Program Definition hom_ord_mixin CL X Y :=
    Preord.Mixin (hom CL X Y) (hom_order X Y) _ _.
  Next Obligation.
    repeat intro. auto.
  Qed.
  Next Obligation.
    repeat intro.
    transitivity (app y x0).
    apply (H x0). apply (H0 x0).
  Qed.

  Canonical Structure hom_ord CL (A B:type CL) :=
    Preord.Pack (CPO.hom CL A B) (CPO.hom_ord_mixin CL A B).

  Program Definition app_to CL (X Y:type CL) (x:X) : Preord.hom (hom_ord CL X Y) (ord Y) :=
    Preord.Hom (hom_ord CL X Y) (ord Y) (fun f => map f x) _.
  Next Obligation.
    intros. apply H.
  Qed.

  Program Definition hom_sup CL (X Y:type CL) (FS:cl_eset CL (hom_ord CL X Y)) : hom CL X Y :=
    Hom CL X Y (fun x => sup_op (image (app_to CL X Y x) FS)) _ _.
  Next Obligation.
    intros.
    apply sup_is_least. red; intros.
    apply image_axiom2 in H0.
    destruct H0 as [y [??]].
    rewrite H1.
    transitivity (app_to CL X Y b y).
    simpl. apply mono. auto.
    apply sup_is_ub.
    apply image_axiom1. auto.
  Qed.
  Next Obligation.
    repeat intro.
    split; repeat intro.
    apply image_axiom2 in H0. destruct H0 as [y [??]].
    simpl in H1.
    rewrite H1.
    apply sup_is_least. red; intros.
    apply image_axiom2 in H2.
    destruct H2 as [y' [??]]. simpl in H3. simpl.
    rewrite H3.
    transitivity (y' lub).
    apply mono. apply H. auto.
    apply sup_is_ub.
    apply image_axiom1'.
    simpl. exists y'. split; auto.

    simpl. apply sup_is_least.
    repeat intro.
    apply image_axiom2 in H1. destruct H1 as [y [??]].
    simpl in H2. rewrite H2.
    destruct (cont y lub XS); auto.
    apply H4.
    hnf; intros.
    apply image_axiom2 in H5. destruct H5 as [q [??]].
    simpl in H6. rewrite H6.
    transitivity (sup_op (image (app_to CL X Y q) FS)).
    apply sup_is_ub. simpl.
    apply image_axiom1'. simpl. exists y. split; auto.
    apply H0.
    apply image_axiom1'. simpl. exists q. split; auto.
  Qed.

  Program Definition hom_mixin CL X Y :=
    Mixin CL (hom_ord CL X Y) (hom_sup CL X Y) _ _.
  Next Obligation.
    intros CL X Y A. red. intros.
    red; intros. unfold hom_sup.
    simpl. red; simpl. intros q.
    apply sup_is_ub.
    change (app x q) with
      ((app_to CL X Y q) x).
    apply image_axiom1; auto.
  Qed.
  Next Obligation.
    repeat intro.
    unfold hom_sup; simpl.
    apply sup_is_least.
    red; intros.
    apply image_axiom2 in H0.
    destruct H0 as [y [??]].
    rewrite H1.
    simpl.
    apply H. auto.
  Qed.

  Canonical Structure hom_cpo CL X Y :=
    Pack CL (hom CL X Y) (hom_ord_mixin CL X Y) (hom_mixin CL X Y).

  Definition cpo_eq_mixin CL X Y := Preord.ord_eq (hom_ord CL X Y).

  Lemma cat_axioms CL : Category.axioms (type CL) (hom CL) (cpo_eq_mixin CL) (comp_mixin CL).
  Proof.
    constructor.

    repeat intro. split. red; simpl; intros. red; simpl; intros. apply ord_refl.
    repeat intro. red; simpl; intros. apply ord_refl.

    repeat intro. split. red; simpl; intros. red; simpl; intros. apply ord_refl.
    repeat intro. red; simpl; intros. apply ord_refl.

    repeat intro. split.
    red; simpl; intros. red; simpl; intros. apply ord_refl.
    red; simpl; intros. red; simpl; intros. apply ord_refl.

    repeat intro. split.
    red; simpl; intros. red; simpl; intros.
    apply ord_trans with (app f (app g' x)).
    unfold app.
    apply mono.
    destruct H0. apply H0.
    destruct H. apply H.
    red; simpl; intros.
    red; simpl; intros.
    apply ord_trans with (app f (app g' x)).
    destruct H. apply H1.
    unfold app; simpl.
    apply mono.
    destruct H0. apply H1.
  Qed.

  Canonical Structure CPO CL := Category (type CL) (hom CL) _ _ (cat_axioms CL).

  Lemma axiom : forall CL (A B:ob (CPO CL)) (f:A → B),
    forall X, f (∐X) ≈ ∐(image f X).
  Proof.
    intros. apply ord_antisym.
    destruct (cont f (sup_op X) X).
    split. apply sup_is_ub.
    apply sup_is_least.
    apply H0; auto.
    repeat intro.
    apply image_axiom2 in H1. destruct H1 as [q [??]].
    simpl in H2. rewrite H2.
    apply sup_is_ub. apply image_axiom1'. exists q; split; auto.

    apply sup_is_least.
    red. intros.
    apply image_axiom2 in H.
    destruct H as [y [??]].
    transitivity (f y).
    destruct H0; auto.
    apply mono.
    apply sup_is_ub; auto.
  Qed.

  Section prod.
    Variable CL:color.
    Variables A B:type CL.

    Program Definition prod_sup (X:cl_eset CL (prod_preord (ord A) (ord B))) : A*B :=
      (∐(image π₁ X), ∐(image π₂ X)).

    Program Definition prod_mixin : mixin_of CL (prod_preord (ord A) (ord B)) :=
      Mixin CL _ prod_sup _ _.
    Next Obligation.
      repeat intro. destruct x as [a b].
      unfold prod_sup. split; simpl.
      apply sup_is_ub. apply image_axiom1'.
      exists (a,b); auto.
      apply sup_is_ub. apply image_axiom1'.
      exists (a,b); auto.
    Qed.
    Next Obligation.
      repeat intro. destruct ub as [ua ub].
      unfold prod_sup; split; simpl;
        apply sup_is_least; repeat intro.
      apply image_axiom2 in H0.
      destruct H0 as [y [??]].
      rewrite H1.
      assert (y ≤ (ua,ub)).
      apply H; auto. destruct H2; auto.
      apply image_axiom2 in H0.
      destruct H0 as [y [??]].
      rewrite H1.
      assert (y ≤ (ua,ub)).
      apply H; auto. destruct H2; auto.
    Qed.

    Definition prod_cpo :=
      Pack CL (A*B) (Preord.mixin (prod_preord (ord A) (ord B))) prod_mixin.

    Program Definition pi1 : prod_cpo → A :=
      Hom CL prod_cpo A (fun x => fst x) _ _.
    Next Obligation.
      intros. destruct H; auto.
    Qed.
    Next Obligation.
      simpl; intros.
      red; intros.
      split; simpl; repeat intro.
      apply image_axiom2 in H0. destruct H0 as [q [??]].
      simpl in H1. rewrite H1.
      destruct H. apply H in H0.
      destruct H0; auto.

      destruct H.
      destruct (H1 (b,snd lub)).
      hnf; intros.
      split; simpl; auto.
      apply H0.
      apply image_axiom1'. simpl. exists x. split; auto.
      apply H in H2. destruct H2; auto.
      simpl in *. auto.
    Qed.

    Program Definition pi2 : prod_cpo → B :=
      Hom CL prod_cpo B (fun x => snd x) _ _.
    Next Obligation.
      intros. destruct H; auto.
    Qed.
    Next Obligation.
      simpl; intros.
      red; intros.
      split; simpl; repeat intro.
      apply image_axiom2 in H0. destruct H0 as [q [??]].
      simpl in H1. rewrite H1.
      destruct H. apply H in H0.
      destruct H0; auto.

      destruct H.
      destruct (H1 (fst lub, b)).
      hnf; intros.
      split; simpl; auto.
      apply H in H2. destruct H2; auto.
      apply H0.
      apply image_axiom1'. simpl. exists x. split; auto.
      simpl in *. auto.
    Qed.
  End prod.

  Program Definition pair CL (C A B:type CL) (f:C → A) (g:C → B) : C → prod_cpo CL A B :=
    Hom CL C (prod_cpo CL A B) (fun x => (f x, g x)) _ _.
  Next Obligation.
    repeat intro. split; simpl; apply mono; auto.
  Qed.
  Next Obligation.
    repeat intro.
    split; hnf; intros.
    apply image_axiom2 in H0. destruct H0 as [y [??]]. simpl in *.
    rewrite H1.
    apply H in H0.
    split; simpl. apply (mono f); auto. apply (mono g); auto.
    simpl.
    split; simpl.
    destruct (cont f lub XS); auto.
    apply H2. hnf; intros.
    apply image_axiom2 in H3. destruct H3 as [q [??]].
    destruct (H0 (f q, g q)).
    apply image_axiom1'. simpl. exists q; split; auto.
    simpl in H5. simpl in H4. rewrite H4; auto.
    destruct (cont g lub XS); auto.
    apply H2. hnf; intros.
    apply image_axiom2 in H3. destruct H3 as [q [??]].
    destruct (H0 (f q, g q)).
    apply image_axiom1'. simpl. exists q; split; auto.
    simpl in H6. simpl in H4. rewrite H4; auto.
  Qed.

End CPO.

(** A "dcpo" is a directed-complete partial order; that is a CPO
    with one of the the directedness color variants.
  *)
Notation dcpo hf := (CPO.type (directed_hf_cl hf)).

(** A "cpo" is a directed-complete cpo not necessarily containing
    a least element.
  *)
Notation cpo  := (CPO.type (directed_hf_cl false)).

(** A "cppo" is a directed-complete pointed partial order; that is
    certainly has a least element.
  *)
Notation cppo := (CPO.type (directed_hf_cl true)).

Notation CPO := CPO.CPO.

Notation dirset := (cl_eset (directed_hf_cl _)).

Canonical Structure CPO.
Canonical Structure CPO.ord.
Canonical Structure CPO.ord_hom.
Canonical Structure CPO.comp.
Canonical Structure CPO.hom_ord.
Canonical Structure CPO.hom_cpo.
Canonical Structure hom_eq CL X Y:=
  Eq.Pack (CPO.hom CL X Y) (Preord.ord_eq (CPO.hom_ord CL X Y)).
Coercion CPO.ord : CPO.type >-> preord.
Coercion CPO.ord_hom : CPO.hom >-> Preord.hom.

Notation "∐ XS" := (@CPO.sup_op _ _ (XS)%set) : cpo_scope.

Arguments CPO.axiom [CL A B] f X.
Arguments CPO.mono [CL A B] h a b _.
Arguments CPO.cont [CL A B] h lub XS _.

(**  Supremum is a monotone operation. *)
Lemma sup_monotone : forall CL (A:CPO.type CL) (X X':cl_eset CL A),
  X ⊆ X' -> ∐X ≤ ∐X'.
Proof.
  intros. apply CPO.sup_is_least. repeat intro.
  apply CPO.sup_is_ub. auto.
Qed.

(**  Supremum respects equality of sets. *)
Lemma sup_equiv : forall CL (A:CPO.type CL) (X X':cl_eset CL A),
  X ≈ X' -> ∐X ≈ ∐X'.
Proof.
  intros. destruct H; split; apply sup_monotone; auto.
Qed.

Class pointed (CL:color) (X:CPO.type CL) :=
  { bottom : X
  ; bottom_least : forall x, bottom ≤ x
  }.

Notation "⊥" := (@bottom _ _ _) : cpo_scope.

Arguments pointed [CL] X.
Hint Resolve bottom_least.

(**  Every cppo has a least element, which arises as the supremum
     of the empty set.
  *)
Section bottom.
  Variables X Y:cppo.

  Lemma empty_semidirected : color_prop (directed_hf_cl true) (∅:eset X).
  Proof.
    hnf; simpl; intros.
    destruct Hinh. apply H in H0.
    apply empty_elem in H0. elim H0.
  Qed.

  Definition empty_dir : dirset X := exist _ ∅ empty_semidirected.

  Definition cppo_bot : X := ∐ empty_dir.

  Lemma cppo_bot_least : forall x, cppo_bot ≤ x.
  Proof.
    intros. unfold cppo_bot.
    apply CPO.sup_is_least.
    repeat intro.
    red in H; simpl in H.
    apply empty_elem in H. elim H.
  Qed.
End bottom.

Instance cppo_pointed (X:cppo) : pointed X :=
  { bottom := cppo_bot X; bottom_least := cppo_bot_least X }.

(**  Every Scott-continuous map between cppos preserves
     the bottom element, i.e., is strict.
  *)
Lemma strict_map (X Y:cppo) (f:X → Y) : f ⊥ ≈ ⊥.
Proof.
  simpl.
  rewrite (CPO.axiom f (empty_dir X)).
  apply sup_equiv.
  split; intros a H.
  apply image_axiom2 in H.
  destruct H as [?[??]].
  red in H; simpl in H.
  apply empty_elem in H. elim H.
  red in H; simpl in H.
  apply empty_elem in H. elim H.
Qed.
Arguments strict_map [X Y] f.

(**  * Chain suprema and least fixed points

     A chain is specified by a base case a monotone operation to iterate,
     where base ≤ step base.

     Every chain gives rise to a directed set and thus has a suprema.
     Suprema of chains have a nice induction principle.
  *)
Require Import NArith.

Lemma Niter_succ A f (a:A) : forall n,
  N.iter (N.succ n) f a = f (N.iter n f a).
Proof.
  induction n using N.peano_ind; simpl; auto.
  rewrite N2Nat.inj_iter.
  rewrite N2Nat.inj_succ.
  simpl. f_equal.
  rewrite <- N2Nat.inj_iter.
  auto.
Qed.

Definition admissible hf (X:dcpo hf) (P:X -> Prop) (q:X) :=
  P q /\ forall XS:dirset X, q ∈ XS -> (forall x, x ∈ XS -> P x) -> P (∐XS).

Arguments admissible [hf X] P q.

Section iter_chain.
  Variable hf:bool.
  Variable X:dcpo hf.

  Variable base : X.
  Variable step : X -> X.

  Hypothesis step_mono : forall x y, x ≤ y -> step x ≤ step y.
  Hypothesis step_base : base ≤ step base.

  Definition iter_chain_set : eset X :=
    fun n => Some (N.iter n step base).

  Lemma iter_le : forall n1 n2,
    (n1 <= n2)%N -> N.iter n1 step base ≤ N.iter n2 step base.
  Proof.
    induction n1 using N.peano_ind; simpl; intros.
    clear H.
    induction n2 using N.peano_ind; simpl; intros.
    auto.
    transitivity (step base); auto.
    repeat rewrite Niter_succ.
    apply step_mono. auto.

    induction n2 using N.peano_ind; simpl.
    elim H. destruct n1; simpl; auto.
    repeat rewrite Niter_succ.
    apply step_mono.
    apply IHn1.
    apply N.succ_le_mono; auto.
  Qed.

  Lemma iter_set_directed : color_prop (directed_hf_cl hf) iter_chain_set.
  Proof.
    red. simpl. apply prove_directed; auto.
    pattern hf at 1. case hf. auto.
    exists base. exists 0%N.
    simpl. auto.

    simpl; intros.
    destruct H as [n1 ?].
    destruct H0 as [n2 ?].
    simpl in H. simpl in H0.
    destruct (N.lt_ge_cases n1 n2).
    exists y.
    split.
    rewrite H. rewrite H0.
    apply iter_le.
    hnf in H1. hnf.
    rewrite H1. discriminate.
    split; auto. exists n2. auto.
    exists x.
    split. auto.
    split.
    rewrite H. rewrite H0.
    apply iter_le; auto.
    exists n1. auto.
  Qed.

  Definition iter_chain : dirset X :=
    exist _ iter_chain_set iter_set_directed.

  Lemma iter_chain_base :
    base ∈ iter_chain.
  Proof.
    exists 0%N. simpl. auto.
  Qed.

  Lemma iter_chain_step : forall x,
    x ∈ iter_chain -> step x ∈ iter_chain.
  Proof.
    intros.
    destruct H as [n ?].
    exists (N.succ n).
    simpl in *. rewrite Niter_succ.
    destruct H; split; apply step_mono; auto.
  Qed.

  Definition chain_sup : X := ∐ iter_chain.

  Lemma chain_induction (P:X -> Prop) :
    admissible P base ->
    (forall x y, x ≈ y -> P x -> P y) ->
    (forall x, P x -> P (step x)) ->
    P chain_sup.
  Proof.
    intros. unfold chain_sup.
    destruct H.
    apply (H2 iter_chain); intros; auto.
    apply iter_chain_base.
    destruct H3 as [n ?]. simpl in *.
    symmetry in H3. apply (H0 _ _ H3). clear x H3.
    induction n using N.peano_ind; simpl; auto.
    rewrite Niter_succ.
    apply H1. auto.
  Qed.
End iter_chain.

(**  The least-fixed point of a continous function in a cpo arises as
     a particular instance of a chain suprema, and the Scott induction
     principle is an instance of chain induction.
  *)
Section lfp.
  Variable X:cpo.
  Variable f:X → X.
  Variable Hpointed : pointed X.

  Definition lfp := chain_sup false X ⊥ f (CPO.mono f) (bottom_least (f ⊥)).

  Lemma scott_induction (P:X -> Prop) :
    admissible P ⊥ ->
    (forall x y, x ≈ y -> P x -> P y) ->
    (forall x, P x -> P (f x)) ->
    P lfp.
  Proof.
    intros. unfold lfp. apply chain_induction; auto.
  Qed.

  Lemma lfp_least : forall x, f x ≈ x -> lfp ≤ x.
  Proof.
    apply scott_induction; intros.
    split; intros; auto.
    apply CPO.sup_is_least. repeat intro.
    apply H0; auto.
    rewrite <- H. apply H0; auto.
    rewrite <- H0.
    apply CPO.mono. apply H; auto.
  Qed.

  Lemma lfp_fixpoint : f lfp ≈ lfp.
  Proof.
    split.

    unfold lfp, chain_sup.
    simpl.
    rewrite (CPO.axiom f (iter_chain false X ⊥ f _ _)).
    apply CPO.sup_is_least; simpl.
    hnf; simpl; intros.
    apply image_axiom2 in H. destruct H as [q [??]]. rewrite H0.
    apply CPO.sup_is_ub. simpl.
    apply iter_chain_step. auto.

    apply scott_induction; auto.
    split; intros; auto.
    apply CPO.sup_is_least.
    hnf; intros.
    transitivity (f x). apply H0; auto.
    apply CPO.mono. apply CPO.sup_is_ub. auto.
    intros. rewrite <- H; auto.
  Qed.
End lfp.

Arguments lfp [X] f [Hpointed].
Arguments scott_induction [X] f [Hpointed] P _ _ _.

(**  The least-fixed point in cpos is uniform.  This fact is somtimes
     called Plotkin's axiom.
  *)
Lemma lfp_uniform (D E:cpo)
  (HD:pointed D) (HE:pointed E)
  (f:D → E) (d:D → D) (e:E → E) :

  f ⊥ ≈ ⊥ ->
  e ∘ f ≈ f ∘ d ->
  lfp e ≈ f (lfp d).
Proof.
  intros. split.

  apply (scott_induction e); intros.
  split; auto. intros.
  apply CPO.sup_is_least. repeat intro; auto.
  rewrite <- H1; auto.
  rewrite H1.
  rewrite <- (lfp_fixpoint D d) at 2.
  destruct H0. apply H0.

  apply (scott_induction d); intros.
  split; intros.
  rewrite H. apply bottom_least.
  rewrite (CPO.axiom f XS).
  apply CPO.sup_is_least. repeat intro.
  apply image_axiom2 in H3. destruct H3 as [y [??]].
  apply H2 in H3.
  rewrite H4. auto.
  rewrite <- H2; auto.
  rewrite <- (lfp_fixpoint E e).
  rewrite <- H1.
  destruct H0. apply H2.
Qed.


Set Implicit Arguments.
Require Import Metalib.Metatheory.
Require Import Program.Equality.
Require Export Transitivity.

Fixpoint subst_label (Z : atom)  (T : typ) {struct T} : typ :=
  match T with
  | typ_top => typ_top
  | typ_nat => typ_nat
  | typ_bvar J => typ_bvar J
  | typ_fvar X =>  (typ_fvar X)
  | typ_arrow T1 T2 => typ_arrow (subst_label Z  T1) (subst_label Z  T2)
  | typ_mu T => typ_mu (subst_label Z  T)
  | typ_label l T => if (l==Z) then (typ_fvar Z) else typ_label l (subst_label Z  T)
  | typ_all T1 T2 => typ_all (subst_label Z T1) (subst_label Z T2)
  end.

Lemma subst_label_open_tt_rec : forall T1 T2 X  k,

  subst_label X  (open_tt_rec k T2 T1) =
    open_tt_rec k (subst_label X  T2) (subst_label X  T1).
Proof with auto.
  intros T1.
  induction T1; intros ; simpl in *; f_equal...

    destruct (k === n); subst...

    destruct (a == X); subst...
    simpl.
    f_equal...
Qed.

Lemma subst_label_open_tt : forall T1 T2 (X:atom),
  subst_label X  (open_tt T1 T2) = open_tt (subst_label X  T1) (subst_label X  T2).
Proof with auto.
  intros.
  unfold open_tt.
  apply subst_label_open_tt_rec...
Qed.

Lemma subst_label_open_tt_var : forall T1 (Y X:atom),
  subst_label X  (open_tt T1 Y) = open_tt (subst_label X  T1) Y.
Proof with auto.
  intros.
  unfold open_tt.
  apply subst_label_open_tt_rec...
Qed.

Definition drop_label (Z : atom) (b : binding) : binding :=
  match b with
  | bind_sub T => bind_sub (subst_label Z T)
  | bind_typ T => bind_typ (subst_label Z T)
  end.

Lemma label_transform2: forall A X X0,
    X <> X0 ->
    (subst_label X (open_tt A (typ_label X0 (open_tt A X0)))) =
(open_tt (subst_label X A) (typ_label X0 (open_tt (subst_label X A) X0))).
Proof with auto.
  intros.
  rewrite subst_label_open_tt...
  f_equal...
  simpl...
  destruct (X0==X)...
  destruct H...
  f_equal...
  rewrite subst_label_open_tt...
Qed.

Lemma In_drop_label_free:forall E X Y U,
    In (Y, bind_sub U) E ->
    X <> Y ->
    In (Y, bind_sub (subst_label X U)) (map (drop_label X) E).
Proof with auto.
  induction E;intros...
  destruct a.
  apply in_inv in H.
  destruct H...
  -
    inversion H;subst.
    simpl...
  -
    simpl...
Qed.

Lemma WF_drop_label : forall E1 X E2 T U,
    WF (E1 ++ (X, bind_sub U) :: E2) T ->
    wf_env (E1 ++ (X, bind_sub U) :: E2) ->
    WF (map (drop_label X) E1++ [(X, bind_sub U)] ++ E2) (subst_label X T).
Proof with auto.
  intros.
  dependent induction H...
  -
    simpl...
    analyze_binds_uniq H...
    +
      apply uniq_from_wf_env...
    +
      apply WF_var with (U:=subst_label X U0)...
      unfold binds.
      apply In_lemmaL.
      apply In_drop_label_free...
    +
      dependent destruction BindsTacVal.
      apply WF_var with (U:=U)...
    +
      apply WF_var with (U:=U0)...
  -
    simpl...
    constructor...
    apply IHWF1...
    apply IHWF2...
  -
    simpl...
    apply WF_all with (L:=L \u dom E1 \u dom E2 \u {{X}});intros...
    apply IHWF...
    rewrite_env (map (drop_label X) (X0 ~ bind_sub T1 ++ E1) ++ (X~ bind_sub U) ++ E2).
    rewrite <- subst_label_open_tt_var.
    apply H1...
    rewrite_env (X0 ~ bind_sub T1 ++ E1 ++ (X, bind_sub U) :: E2)...
  -
    simpl.
    apply WF_rec with (L:=L \u {{X}}\u dom E1 \u dom E2);intros...
    +
      rewrite <- subst_label_open_tt_var.
      rewrite_env (map (drop_label X) (X0 ~ bind_sub typ_top ++ E1) ++ (X~ bind_sub U) ++ E2).
      apply H0...
      rewrite_env (X0 ~ bind_sub typ_top ++ E1 ++ (X, bind_sub U) :: E2)...
    +
      rewrite <- label_transform2...
      rewrite_env (map (drop_label X) (X0 ~ bind_sub typ_top ++ E1) ++ (X~ bind_sub U) ++ E2).
      apply H2...
      rewrite_env (X0 ~ bind_sub typ_top ++ E1 ++ (X, bind_sub U) :: E2)...
  -
    simpl...
    destruct (X0==X);subst...
    +
      apply WF_var with (U:=U)...
    +
      constructor...
      apply IHWF...
Qed.

Lemma wf_env_drop_label : forall E1 E2 X,
    wf_env (E1 ++ [(X, bind_sub typ_top)] ++ E2) ->
    wf_env (map (drop_label X) E1++ [(X, bind_sub typ_top)] ++ E2).
Proof with auto.
  induction E1;intros...
  destruct a.
  dependent destruction H...
  -
    simpl...
    constructor...
    apply IHE1...
    apply WF_drop_label...
  -
    simpl...
    constructor...
    apply IHE1...
    apply WF_drop_label...
Qed.

Lemma drop_label_fresh: forall T X,
    X \notin fl_tt T ->
    T = subst_label X T.
Proof with auto.
  induction T;intros;simpl in *;try solve [f_equal;auto]...
  -
    destruct (a==X);subst...
    +
      apply notin_union in H.
      destruct_hypos.
      apply notin_singleton_1 in H...
      destruct H...
    +
      f_equal...
Qed.

Lemma maps_drop_label_free: forall E X,
    X \notin fl_env E ->
    map (drop_label X) E = E.
Proof with auto.
  induction E;intros...
  destruct a.
  destruct b.
  -
    simpl in *.
    f_equal...
    f_equal...
    f_equal...
    rewrite <- drop_label_fresh...
  -
    simpl in *.
    f_equal...
    f_equal...
    f_equal...
    rewrite <- drop_label_fresh...
Qed.

Lemma binds_drop_label_free: forall F X  Y U ,
    In (X, bind_sub U) F ->
    X <> Y ->
    In (X, bind_sub (subst_label Y U)) (map (drop_label Y) F).
Proof with auto.
  induction F;intros...
  apply in_inv in H.
  destruct H...
  -
    destruct a.
    inversion H;subst.
    simpl...
  -
    simpl...
Qed.

Lemma drop_label_reverse_type: forall A U X,
    X \notin fl_tt A ->
    subst_label X (subst_tt X (typ_label X U) A) = A.
Proof with auto.
  induction A;intros;simpl in *;try solve [f_equal;auto]...
  -
    destruct (a==X);subst...
    simpl...
    destruct (X==X)...
    destruct n...
  -
    destruct (a==X);subst...
    solve_notin_self X.
    f_equal...
Qed.

Lemma drop_label_reverse_env: forall E X U,
    X \notin fl_env E ->
    map (drop_label X) (map (subst_tb X (typ_label X U)) E) = E.
Proof with auto.
  induction E;intros...
  simpl in *.
  destruct a.
  destruct b.
  f_equal...
  f_equal...
  simpl;f_equal;
  apply drop_label_reverse_type...
  f_equal...
  f_equal...
  simpl;f_equal;
  apply drop_label_reverse_type...
Qed.

Lemma open_twice_to_one: forall E1 E2 A B X,
    sub (E1++ [(X, bind_sub typ_top)] ++ E2) A B ->
    X \notin fl_env E2 ->
    sub (map (drop_label X) E1++ [(X, bind_sub typ_top)] ++ E2) (subst_label X A) (subst_label X B).
Proof with eauto.
  intros.
  assert (wf_env (E1++ [(X, bind_sub typ_top)] ++ E2)) as HE.
  get_well_form...
  dependent induction H;simpl in *...
  -
    constructor...
    apply wf_env_drop_label...
  -
    constructor...
    apply wf_env_drop_label...
    assert (typ_fvar X0 = subst_label X (typ_fvar X0)) by auto.
    rewrite H2.
    apply WF_drop_label...
  -
    constructor...
    apply wf_env_drop_label...
    apply WF_drop_label...
  -
    apply sa_trans_tvar with (U:=subst_label X U)...
    analyze_binds_uniq H.
    +
      get_well_form.
      apply uniq_from_wf_env...
    +
      unfold binds in *.
      apply In_lemmaL.
      apply In_drop_label_free...
    +
      inversion BindsTacVal...
    +
      unfold binds in *.
      apply In_lemmaR.
      apply in_cons.
      apply binds_drop_label_free with (Y:=X) in BindsTac0...
      rewrite <-  maps_drop_label_free with (X:=X)...
  -
    apply sa_all with (L:=L \u {{X}} \u dom E1 \u dom E2);intros...
    apply WF_drop_label...
    rewrite_env (map (drop_label X) (X0 ~ bind_sub S ++ E1) ++ (X~ bind_sub typ_top) ++ E2).
    rewrite <- subst_label_open_tt_var.
    rewrite <- subst_label_open_tt_var.
    apply H1...
    rewrite_env (X0 ~ bind_sub S ++ E1 ++ (X, bind_sub typ_top) :: E2)...
  -
    apply sa_rec with (L:=L \u {{X}}\u dom E1 \u dom E2);intros...
    +
      rewrite <- subst_label_open_tt_var.
      rewrite_env (map (drop_label X) (X0 ~ bind_sub typ_top ++ E1) ++ (X~ bind_sub typ_top) ++ E2).
      apply WF_drop_label...
      apply H...
      rewrite_env (X0 ~ bind_sub typ_top ++ E1 ++ (X, bind_sub typ_top) :: E2)...
    +
      rewrite <- subst_label_open_tt_var.
      rewrite_env (map (drop_label X) (X0 ~ bind_sub typ_top ++ E1) ++ (X~ bind_sub typ_top) ++ E2).
      apply WF_drop_label...
      apply H0...
      rewrite_env (X0 ~ bind_sub typ_top ++ E1 ++ (X, bind_sub typ_top) :: E2)...
    +
      rewrite <- label_transform2...
      rewrite <- label_transform2...
      rewrite_env (map (drop_label X) (X0 ~ bind_sub typ_top ++ E1) ++ (X~ bind_sub typ_top) ++ E2).
      apply H2...
      rewrite_env  (X0 ~ bind_sub typ_top ++ E1 ++ (X, bind_sub typ_top) :: E2)...
  -
    destruct (X0==X);subst...
    constructor...
    apply wf_env_drop_label...
Qed.

Lemma label_transform: forall A X B ,
    X \notin fl_tt A ->
    subst_label X (open_tt A (typ_label X B) ) = open_tt A X .
Proof with auto.
  intro A.
  unfold open_tt.
  generalize 0.
  induction A;intros;simpl in *;try solve [f_equal;auto]...
  -
    destruct (n0==n)...
    simpl...
    destruct (X==X)...
    destruct n1...
  -
    destruct (a==X)...
    subst.
    apply notin_union in H.
    destruct H.
    apply notin_singleton_1 in H.
    destruct H...
    f_equal...
Qed.

Lemma sub_nominal_inversion: forall E X A B,
    sub (X~bind_sub typ_top ++ E) (open_tt A (typ_label X (open_tt A X))) (open_tt B (typ_label X (open_tt B X))) ->
    X \notin  fl_tt A \u fl_tt B \u fl_env E ->
    sub (X~bind_sub typ_top ++ E) (open_tt A X) (open_tt B X).
Proof with auto.
  intros.
  rewrite_env (nil ++ X~bind_sub typ_top ++ E) in H.
  apply open_twice_to_one in H...
  rewrite label_transform in H...
  rewrite label_transform in H...
Qed.

Lemma WF_strengthening: forall E1 E2 X A  U,
    WF (E1 ++ X ~ U ++ E2) A  ->
    X \notin fv_env E1 \u fv_tt A  ->
    wf_env (E1++E2) ->
    WF (E1 ++ E2) A .
Proof with eauto.
  intros.
  dependent induction H;simpl in *...
  -
    apply WF_var with (U:=U0)...
    analyze_binds H...
  -
    apply WF_all with (L:=L \u {{X}} \u dom E1 \u dom E2);intros...
    rewrite_env ((X0 ~ bind_sub T1 ++ E1) ++ E2).
    apply H1 with (X1:=X) (U0:=U)...
    solve_notin.
    rewrite_env (X0 ~ bind_sub T1 ++ E1 ++ E2)...
  -
    apply WF_rec with (L:=L \u {{X}} \u dom E1 \u dom E2);intros...
    rewrite_env ((X0 ~ bind_sub typ_top ++ E1) ++ E2).
    apply H0 with (X1:=X) (U0:=U)...
    solve_notin.
    rewrite_env (X0 ~ bind_sub typ_top ++ E1 ++ E2)...
    rewrite_env ((X0 ~ bind_sub typ_top ++ E1) ++ E2).
    apply H2 with (X1:=X) (U0:=U)...
    solve_notin.
    rewrite_env (X0 ~ bind_sub typ_top ++ E1 ++ E2)...
Qed.

Lemma notin_fv_tt_fv_env: forall E T X Y,
    binds Y (bind_sub T) E ->
    X \notin fv_env E ->
    X \notin fv_tt T.
Proof with auto.
  induction E;intros...
  simpl in *...
  destruct a.
  analyze_binds H...
  destruct b...
  apply IHE with (Y:=Y)...
  apply IHE with (Y:=Y)...
Qed.

Lemma notin_from_wf_env_spec: forall E1 X T E2,
    wf_env (E1 ++ (X,  T) :: E2) ->
    X \notin dom E2 \u fv_env E2.
Proof with auto.
  induction E1;intros...
  -
    dependent destruction H...
    apply fv_env_ls_dom in H...
    apply fv_env_ls_dom in H...
  -
    dependent destruction H...
    simpl in *...
    apply IHE1 in H...
    simpl in *...
    apply IHE1 in H...
Qed.

Lemma notin_fv_tt_binds: forall X U Y T E1 E2,
    binds Y (bind_sub T) (E1 ++ (X, U) :: E2) ->
    wf_env (E1 ++ (X, U) :: E2) ->
    X \notin fv_env E1 \u {{Y}} ->
    X \notin fv_tt T.
Proof with auto.
  intros.
  analyze_binds_uniq H...
  -
    apply uniq_from_wf_env...
  -
    apply notin_fv_tt_fv_env with (X:=X) in BindsTac...
  -
    apply notin_fv_tt_fv_env with (X:=X) in BindsTac0...
    apply notin_from_wf_env_spec in H0...
Qed.

Lemma sub_strengthening: forall E1 E2 X A B U,
    sub (E1 ++ X ~ U ++ E2) A B ->
    X \notin fv_env E1 \u fv_tt A \u fv_tt B ->
    wf_env (E1++E2) ->
    sub (E1 ++ E2) A B.
Proof with eauto.
  intros.
  dependent induction H;simpl in *...
  -
    constructor...
    dependent destruction H0.
    apply WF_var with (U:=U0)...
    analyze_binds H0...
  -
    constructor...
    apply WF_strengthening in H0...
  -
    apply sa_trans_tvar with (U:=U0)...
    analyze_binds H...
    apply IHsub with (X0:=X) (U1:=U)...
    solve_notin.
    apply notin_fv_tt_binds in H...
    get_well_form...
  -
    apply sa_all with (L:=L \u {{X}} \u dom E1 \u dom E2);intros...
    apply WF_strengthening in H...
    rewrite_env ((X0 ~ bind_sub S ++ E1) ++ E2).
    apply H1 with (X1:=X) (U0:=U)...
    solve_notin.
    rewrite_env (X0 ~ bind_sub S ++ E1 ++ E2)...
    constructor...
    apply WF_strengthening in H...
  -
    apply sa_rec with (L:=L \u {{X}} \u dom E1 \u dom E2);intros...
    +
      specialize_x_and_L X0 L.
      rewrite_env (((X0, bind_sub typ_top) :: E1) ++ (X, U) :: E2) in H.
      apply WF_strengthening in H...
      solve_notin.
      rewrite_env (X0 ~ bind_sub typ_top ++ E1 ++ E2)...
    +
      specialize_x_and_L X0 L.
      rewrite_env (((X0, bind_sub typ_top) :: E1) ++ (X, U) :: E2) in H0.
      apply WF_strengthening in H0...
      solve_notin.
      rewrite_env (X0 ~ bind_sub typ_top ++ E1 ++ E2)...
    +
      rewrite_env ((X0 ~ bind_sub typ_top ++ E1) ++ E2)...
      apply H2 with (X1:=X) (U0:=U)...
      solve_notin.
      rewrite_env (X0 ~ bind_sub typ_top ++ E1 ++ E2)...
Qed.

Lemma sub_strengthening_env: forall E1 E2 A B,
    sub (E1 ++ E2) A B ->
    wf_env E2 ->
    WF E2 A ->
    WF E2 B ->
    sub E2 A B.
Proof with auto.
  induction E1;intros...
  destruct a.
  rewrite_env (nil ++ a ~ b ++ E1 ++ E2) in H.
  apply sub_strengthening in H...
  get_well_form.
  apply notin_from_wf_env_spec in H...
  apply WF_imply_dom in H1.
  apply WF_imply_dom in H2...
  solve_notin.
  apply notin_partial with (E2:=dom E2)...
  apply notin_partial with (E2:=dom E2)...
  get_well_form...
  simpl in *...
  dependent destruction H...
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** A library for finite sets, implemented as lists *)

(** This is a light implementation of finite sets as lists; for a more
    extensive library, you might rather consider MSetWeakList.v. In
    addition, if your domain is totally ordered, you might also
    consider implementations of finite sets with access in logarithmic
    time (e.g. MSetRBT.v which is based on red-black trees). *)

Require Import List.

Set Implicit Arguments.

Section first_definitions.

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

  Definition set := list A.

  Definition empty_set : set := nil.

  Fixpoint set_add (a:A) (x:set) : set :=
    match x with
    | nil => a :: nil
    | a1 :: x1 =>
        match Aeq_dec a a1 with
        | left _ => a1 :: x1
        | right _ => a1 :: set_add a x1
        end
    end.

  Fixpoint set_mem (a:A) (x:set) : bool :=
    match x with
    | nil => false
    | a1 :: x1 =>
        match Aeq_dec a a1 with
        | left _ => true
        | right _ => set_mem a x1
        end
    end.

  (** If [a] belongs to [x], removes [a] from [x]. If not, does nothing *)
  Fixpoint set_remove (a:A) (x:set) : set :=
    match x with
    | nil => empty_set
    | a1 :: x1 =>
        match Aeq_dec a a1 with
        | left _ => x1
        | right _ => a1 :: set_remove a x1
        end
    end.

  Fixpoint set_inter (x:set) : set -> set :=
    match x with
    | nil => fun y => nil
    | a1 :: x1 =>
        fun y =>
          if set_mem a1 y then a1 :: set_inter x1 y else set_inter x1 y
    end.

  Fixpoint set_union (x y:set) : set :=
    match y with
    | nil => x
    | a1 :: y1 => set_add a1 (set_union x y1)
    end.

  (** returns the set of all els of [x] that does not belong to [y] *)
  Fixpoint set_diff (x y:set) : set :=
    match x with
    | nil => nil
    | a1 :: x1 =>
        if set_mem a1 y then set_diff x1 y else set_add a1 (set_diff x1 y)
    end.

  Definition set_In : A -> set -> Prop := In (A:=A).

  Lemma set_In_dec : forall (a:A) (x:set), {set_In a x} + {~ set_In a x}.

  Proof.
    unfold set_In.
    (*** Realizer set_mem. Program_all. ***)
    simple induction x.
    auto.
    intros a0 x0 Ha0. case (Aeq_dec a a0); intro eq.
    rewrite eq; simpl; auto with datatypes.
    elim Ha0.
    auto with datatypes.
    right; simpl; unfold not; intros [Hc1| Hc2];
     auto with datatypes.
  Qed.

  Lemma set_mem_ind :
   forall (B:Type) (P:B -> Prop) (y z:B) (a:A) (x:set),
     (set_In a x -> P y) -> P z -> P (if set_mem a x then y else z).

  Proof.
    simple induction x; simpl; intros.
    assumption.
    elim (Aeq_dec a a0); auto with datatypes.
  Qed.

  Lemma set_mem_ind2 :
   forall (B:Type) (P:B -> Prop) (y z:B) (a:A) (x:set),
     (set_In a x -> P y) ->
     (~ set_In a x -> P z) -> P (if set_mem a x then y else z).

  Proof.
    simple induction x; simpl; intros.
    apply H0; red; trivial.
    case (Aeq_dec a a0); auto with datatypes.
    intro Hneg; apply H; intros; auto.
    apply H1; red; intro.
    case H3; auto.
  Qed.

  Lemma set_mem_correct1 :
   forall (a:A) (x:set), set_mem a x = true -> set_In a x.
  Proof.
    simple induction x; simpl.
    discriminate.
    intros a0 l; elim (Aeq_dec a a0); auto with datatypes.
  Qed.

  Lemma set_mem_correct2 :
   forall (a:A) (x:set), set_In a x -> set_mem a x = true.
  Proof.
    simple induction x; simpl.
    intro Ha; elim Ha.
    intros a0 l; elim (Aeq_dec a a0); auto with datatypes.
    intros H1 H2 [H3| H4].
    absurd (a0 = a); auto with datatypes.
    auto with datatypes.
  Qed.

  Lemma set_mem_complete1 :
   forall (a:A) (x:set), set_mem a x = false -> ~ set_In a x.
  Proof.
    simple induction x; simpl.
    tauto.
    intros a0 l; elim (Aeq_dec a a0).
    intros _ _ [=].
    unfold not; intros H H0 H1 [|]; auto with datatypes.
  Qed.

  Lemma set_mem_complete2 :
   forall (a:A) (x:set), ~ set_In a x -> set_mem a x = false.
  Proof.
    simple induction x; simpl.
    tauto.
    intros a0 l; elim (Aeq_dec a a0).
    intros H H0 []; auto with datatypes.
    tauto.
  Qed.

  Lemma set_add_intro1 :
   forall (a b:A) (x:set), set_In a x -> set_In a (set_add b x).

  Proof.
    unfold set_In; simple induction x; simpl.
    auto with datatypes.
    intros a0 l H [Ha0a| Hal].
    elim (Aeq_dec b a0); left; assumption.
    elim (Aeq_dec b a0); right; [ assumption | auto with datatypes ].
  Qed.

  Lemma set_add_intro2 :
   forall (a b:A) (x:set), a = b -> set_In a (set_add b x).

  Proof.
    unfold set_In; simple induction x; simpl.
    auto with datatypes.
    intros a0 l H Hab.
    elim (Aeq_dec b a0);
     [ rewrite Hab; intro Hba0; rewrite Hba0; simpl;
        auto with datatypes
     | auto with datatypes ].
  Qed.

  Hint Resolve set_add_intro1 set_add_intro2.

  Lemma set_add_intro :
   forall (a b:A) (x:set), a = b \/ set_In a x -> set_In a (set_add b x).

  Proof.
    intros a b x [H1| H2]; auto with datatypes.
  Qed.

  Lemma set_add_elim :
   forall (a b:A) (x:set), set_In a (set_add b x) -> a = b \/ set_In a x.

  Proof.
    unfold set_In.
    simple induction x.
    simpl; intros [H1| H2]; auto with datatypes.
    simpl; do 3 intro.
    elim (Aeq_dec b a0).
    simpl; tauto.
    simpl; intros H0 [|].
    trivial with datatypes.
    tauto.
    tauto.
  Qed.

  Lemma set_add_elim2 :
   forall (a b:A) (x:set), set_In a (set_add b x) -> a <> b -> set_In a x.
   intros a b x H; case (set_add_elim _ _ _ H); intros; trivial.
   case H1; trivial.
   Qed.

  Hint Resolve set_add_intro set_add_elim set_add_elim2.

  Lemma set_add_not_empty : forall (a:A) (x:set), set_add a x <> empty_set.
  Proof.
    simple induction x; simpl.
    discriminate.
    intros; elim (Aeq_dec a a0); intros; discriminate.
  Qed.

  Lemma set_union_intro1 :
   forall (a:A) (x y:set), set_In a x -> set_In a (set_union x y).
  Proof.
    simple induction y; simpl; auto with datatypes.
  Qed.

  Lemma set_union_intro2 :
   forall (a:A) (x y:set), set_In a y -> set_In a (set_union x y).
  Proof.
    simple induction y; simpl.
    tauto.
    intros; elim H0; auto with datatypes.
  Qed.

  Hint Resolve set_union_intro2 set_union_intro1.

  Lemma set_union_intro :
   forall (a:A) (x y:set),
     set_In a x \/ set_In a y -> set_In a (set_union x y).
  Proof.
    intros; elim H; auto with datatypes.
  Qed.

  Lemma set_union_elim :
   forall (a:A) (x y:set),
     set_In a (set_union x y) -> set_In a x \/ set_In a y.
  Proof.
    simple induction y; simpl.
    auto with datatypes.
    intros.
    generalize (set_add_elim _ _ _ H0).
    intros [H1| H1].
    auto with datatypes.
    tauto.
  Qed.

  Lemma set_union_emptyL :
   forall (a:A) (x:set), set_In a (set_union empty_set x) -> set_In a x.
    intros a x H; case (set_union_elim _ _ _ H); auto || contradiction.
  Qed.

  Lemma set_union_emptyR :
   forall (a:A) (x:set), set_In a (set_union x empty_set) -> set_In a x.
    intros a x H; case (set_union_elim _ _ _ H); auto || contradiction.
  Qed.

  Lemma set_inter_intro :
   forall (a:A) (x y:set),
     set_In a x -> set_In a y -> set_In a (set_inter x y).
  Proof.
    simple induction x.
    auto with datatypes.
    simpl; intros a0 l Hrec y [Ha0a| Hal] Hy.
    simpl; rewrite Ha0a.
    generalize (set_mem_correct1 a y).
    generalize (set_mem_complete1 a y).
    elim (set_mem a y); simpl; intros.
    auto with datatypes.
    absurd (set_In a y); auto with datatypes.
    elim (set_mem a0 y); [ right; auto with datatypes | auto with datatypes ].
  Qed.

  Lemma set_inter_elim1 :
   forall (a:A) (x y:set), set_In a (set_inter x y) -> set_In a x.
  Proof.
    simple induction x.
    auto with datatypes.
    simpl; intros a0 l Hrec y.
    generalize (set_mem_correct1 a0 y).
    elim (set_mem a0 y); simpl; intros.
    elim H0; eauto with datatypes.
    eauto with datatypes.
  Qed.

  Lemma set_inter_elim2 :
   forall (a:A) (x y:set), set_In a (set_inter x y) -> set_In a y.
  Proof.
    simple induction x.
    simpl; tauto.
    simpl; intros a0 l Hrec y.
    generalize (set_mem_correct1 a0 y).
    elim (set_mem a0 y); simpl; intros.
    elim H0;
     [ intro Hr; rewrite <- Hr; eauto with datatypes | eauto with datatypes ].
    eauto with datatypes.
  Qed.

  Hint Resolve set_inter_elim1 set_inter_elim2.

  Lemma set_inter_elim :
   forall (a:A) (x y:set),
     set_In a (set_inter x y) -> set_In a x /\ set_In a y.
  Proof.
    eauto with datatypes.
  Qed.

  Lemma set_diff_intro :
   forall (a:A) (x y:set),
     set_In a x -> ~ set_In a y -> set_In a (set_diff x y).
  Proof.
    simple induction x.
    simpl; tauto.
    simpl; intros a0 l Hrec y [Ha0a| Hal] Hay.
    rewrite Ha0a; generalize (set_mem_complete2 _ _ Hay).
    elim (set_mem a y);
     [ intro Habs; discriminate Habs | auto with datatypes ].
    elim (set_mem a0 y); auto with datatypes.
  Qed.

  Lemma set_diff_elim1 :
   forall (a:A) (x y:set), set_In a (set_diff x y) -> set_In a x.
  Proof.
    simple induction x.
    simpl; tauto.
    simpl; intros a0 l Hrec y; elim (set_mem a0 y).
    eauto with datatypes.
    intro; generalize (set_add_elim _ _ _ H).
    intros [H1| H2]; eauto with datatypes.
  Qed.

  Lemma set_diff_elim2 :
   forall (a:A) (x y:set), set_In a (set_diff x y) -> ~ set_In a y.
  intros a x y; elim x; simpl.
  intros; contradiction.
  intros a0 l Hrec.
  apply set_mem_ind2; auto.
  intros H1 H2; case (set_add_elim _ _ _ H2); intros; auto.
  rewrite H; trivial.
  Qed.

  Lemma set_diff_trivial : forall (a:A) (x:set), ~ set_In a (set_diff x x).
  red; intros a x H.
  apply (set_diff_elim2 _ _ _ H).
  apply (set_diff_elim1 _ _ _ H).
  Qed.

Hint Resolve set_diff_intro set_diff_trivial.

End first_definitions.

Section other_definitions.

  Definition set_prod : forall {A B:Type}, set A -> set B -> set (A * B) :=
    list_prod.

  (** [B^A], set of applications from [A] to [B] *)
  Definition set_power : forall {A B:Type}, set A -> set B -> set (set (A * B)) :=
    list_power.

  Definition set_fold_left {A B:Type} : (B -> A -> B) -> set A -> B -> B :=
    fold_left (A:=B) (B:=A).

  Definition set_fold_right {A B:Type} (f:A -> B -> B) (x:set A)
    (b:B) : B := fold_right f b x.

  Definition set_map {A B:Type} (Aeq_dec : forall x y:B, {x = y} + {x <> y})
    (f : A -> B) (x : set A) : set B :=
    set_fold_right (fun a => set_add Aeq_dec (f a)) x (empty_set B).

End other_definitions.

Unset Implicit Arguments.