(* Full safety for STLC *)
(* values well-typed with respect to runtime environment *)
(* inversion lemma structure *)
(* subtyping (in addition to nano2.v) *)
(* singleton types (in addtion to nano4-1.v *)

(* full proof for singleton types! *)
(* added stp_vary rule *)

(* TODO: type members *)
(* TODO: dependent application *)

(* small-step style !! *)

Require Export SfLib.

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

Module STLC.

Definition id := nat.

Inductive ty : Type :=
  | TBot   : ty
  | TTop   : ty
  | TBool  : ty
  | TFun   : ty -> ty -> ty
  | TVar   : bool -> id -> ty
  | TVarB  : id -> ty
  | TMem   : ty -> ty -> ty (* intro *)
  | TSel   : ty -> ty (* elim *)
  | TBind  : ty -> ty
.

Inductive tm : Type :=
  | ttrue : tm
  | tfalse : tm
  | tvar : id -> tm
  | tapp : tm -> tm -> tm (* f(x) *)
  | tabs : tm -> tm (* \f x.y *)
.

Inductive vl : Type :=
  | vbool : bool -> vl
  | vabs  : list vl -> tm -> vl
  | vty   : list vl -> ty -> vl
.

Definition venv := list vl.
Definition tenv := list ty.

Definition aenv := list (venv*ty).

Hint Unfold venv.
Hint Unfold tenv.
Hint Unfold aenv.

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

(* closed j k means normal variables < j, bound variables < k *)
Inductive closed: nat -> nat -> nat -> ty -> Prop :=
| cl_bot: forall i j k,
    closed i j k TBot
| cl_top: forall i j k,
    closed i j k TTop
| cl_bool: forall i j k,
    closed i j k TBool
| cl_fun: forall i j k T1 T2,
    closed i j k T1 ->
    closed i j k T2 ->
    closed i j k (TFun T1 T2)
| cl_var0: forall i j k x,
    i > x ->
    closed i j k (TVar false x)
| cl_var1: forall i j k x,
    j > x ->
    closed i j k (TVar true x)
| cl_varB: forall i j k x,
    k > x ->
    closed i j k (TVarB x)
| cl_mem: forall i j k T1 T2,
    closed i j k T1 ->
    closed i j k T2 ->
    closed i j k (TMem T1 T2)
| cl_sel: forall i j k T1,
    closed i j k T1 ->
    closed i j k (TSel T1)
| cl_bind: forall i j k T1,
    closed i j (S k) T1 ->
    closed i j k (TBind T1)
.

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

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

(*
Fixpoint nosubst (T : ty) {struct T} : Prop :=
  match T with
    | TTop         => True
    | TBot         => True
    | TBool        => True
    | TMem m T1 T2   => nosubst T1 /\ nosubst T2
    | TSel (varB i) m => True
    | TSel (varF i) m => True
    | TSel (varH i) m => i <> 0
    | TAll m T1 T2   => nosubst T1 /\ nosubst T2
    | TBind T2     => nosubst T2
    | TAnd T1 T2   => nosubst T1 /\ nosubst T2
    | TOr  T1 T2   => nosubst T1 /\ nosubst T2
  end.
*)

Inductive real: ty -> Prop :=
| real_var: forall b x,
    real (TVar b x)
| real_mem: forall T,
    real (TMem T T)
.

Inductive stp: tenv -> ty -> ty -> Prop :=
| stp_bool: forall G1,
    stp G1 TBool TBool
| stp_fun: forall G1 T1 T2 T3 T4,
    stp G1 T3 T1 ->
    stp G1 T2 T4 ->
    stp G1 (TFun T1 T2) (TFun T3 T4)
| stp_varx: forall G1 x,
    x < length G1 ->
    stp G1 (TVar false x) (TVar false x)
| stp_vary: forall G1 x y,
    index x G1 = Some (TVar false y) ->
    y < length G1 ->
    stp G1 (TVar false y) (TVar false x)
| stp_var1: forall G1 x T1,
    index x G1 = Some T1 ->
    closed (length G1) 0 0 T1 ->
    stp G1 (TVar false x) T1
| stp_mem: forall G1 T1 T2 T3 T4,
    stp G1 T3 T1 ->
    stp G1 T2 T4 ->
    stp G1 (TMem T1 T2) (TMem T3 T4)
| stp_sel: forall G1 T1 T2,
    stp G1 T1 T2 ->
    stp G1 T2 T1 ->
    stp G1 (TSel T1) (TSel T2)
| stp_red: forall G1 T1 T2,
    stp G1 T1 (TMem TBot T2) ->
    stp G1 (TSel T1) T2
| stp_red2: forall G1 T1 T2 T0,
    real T0 ->
    stp G1 T0 T2 -> (* this is the main trick ... *)
    stp G1 T2 (TMem T1 TTop) ->
    stp G1 T1 (TSel T2)

(* bind! *)
.

Inductive has_type : tenv -> tm -> ty -> Prop :=
| t_true: forall env,
    has_type env ttrue TBool
| t_false: forall env,
    has_type env tfalse TBool
| t_varx: forall x env T1,
    index x env = Some T1 -> (* could use closed *)
    has_type env (tvar x) (TVar false x)
(*| t_var: forall x env T1,
    index x env = Some T1 ->
    has_type env (tvar x) T1*)
| t_app: forall env f x T1 T2,
    has_type env f (TFun T1 T2) ->
    has_type env x T1 ->
    has_type env (tapp f x) T2
| t_abs: forall env y T1 T2,
    has_type (T1::(TFun T1 T2)::env) y T2 ->
    closed (length env) 0 0 (TFun T1 T2) ->
    has_type env (tabs y) (TFun T1 T2)
| t_sub: forall env x T1 T2,
    has_type env x T1 ->
    stp env T1 T2 ->
    has_type env x T2
.

Inductive stp2: nat -> bool -> aenv -> venv -> ty -> venv -> ty -> nat -> Prop :=
| stp2_bot: forall m GH G1 G2 T n1,
    closed (length GH) (length G2) 0  T ->
    stp2 m true GH G1 TBot G2 T (S n1)
| stp2_top: forall m GH G1 G2 T n1,
    closed (length GH) (length G1) 0 T ->
    stp2 m true GH G1 T G2 TTop (S n1)
| stp2_bool: forall m GH G1 G2 n1,
    stp2 m true GH G1 TBool G2 TBool (S n1)
| stp2_fun: forall m GH G1 G2 T1 T2 T3 T4 n1 n2,
    stp2 m false GH G2 T3 G1 T1 n1 ->
    stp2 m false GH G1 T2 G2 T4 n2 ->
    stp2 m true GH G1 (TFun T1 T2) G2 (TFun T3 T4) (S (n1+n2))

| stp2_varx: forall m GH G1 G2 x1 x2 v n1,
    index x1 G1 = Some v ->
    index x2 G2 = Some v ->
    stp2 m true GH G1 (TVar true x1) G2 (TVar true x2) (S n1)
| stp2_var1: forall m GH G1 GX TX G2 x T2 v n1,
    index x G1 = Some v ->
    val_type0 GX v TX -> (* slack for: val_type G2 v T2 *)
    stp2 m true GH GX TX G2 T2 n1 ->
    stp2 m true GH G1 (TVar true x) G2 T2 (S n1)
| stp2_var1b: forall m GH G1 GX TX G2 x x2 T2 v n1 n2,
    index x G1 = Some v ->
    index x2 G2 = Some v ->
    val_type0 GX v TX -> (* slack for: val_type G2 v T2 *)
    stp2 m true ((G1,(TVar true x))::GH) GX TX G2 (open 0 (TVar false (length GH)) T2) n1 ->
    stp2 m true GH GX TX G2 (open 0 (TVar true x2) T2) n2 ->
    stp2 m true GH G1 (TVar true x) G2 (TBind T2) (S (n1+n2))

| stp2_varax: forall m GH G1 G2 x n1,
    x < length GH ->
    stp2 m true GH G1 (TVar false x) G2 (TVar false x) (S n1)
| stp2_varay: forall m GH G1 G2 GX x1 x2 n1,
    index x1 GH = Some (GX, (TVar false x2)) ->
    x2 < length GH ->
    stp2 m true GH G1 (TVar false x2) G2 (TVar false x1) (S n1)
| stp2_vara1: forall m GH G1 GX TX G2 x T2 n1,
    index x GH = Some (GX, TX) ->
    stp2 m true GH GX TX G2 T2 n1 ->
    stp2 m true GH G1 (TVar false x) G2 T2 (S n1)

| stp2_mem: forall m GH G1 G2 T1 T2 T3 T4 n1 n2,
    stp2 m false GH G2 T3 G1 T1 n2 ->
    stp2 m true GH G1 T2 G2 T4 n1 ->
    stp2 m true GH G1 (TMem T1 T2) G2 (TMem T3 T4) (S (n1+n2))
| stp2_sel: forall m GH G1 G2 T1 T2 n1 n2,
    stp2 m false GH G2 T2 G1 T1 n2 ->
    stp2 m true GH G1 T1 G2 T2 n1 ->
    stp2 m true GH G1 (TSel T1) G2 (TSel T2) (S (n1+n2))
| stp2_red: forall m GH G1 G2 T1 T2 n1,
    stp2 m true GH G1 T1 G2 (TMem TBot T2) n1 ->
    stp2 m true GH G1 (TSel T1) G2 T2 (S n1)
| stp2_red2: forall m GH G1 G2 GX TX T1 T2 GY T0 n0 n1 n2 n3,
(* long form of:
    stp2 true GY (TVar y) G2 T2 n0 ->
    stp2 true G2 T2 G1 (TMem T1 TTop) n1 -> *)
    real T0 ->
    stp2 m true GH GY T0 G2 T2 n0 ->
    stp2 m false GH G2 T2 GX (TMem TX TTop) n1 ->
    stp2 m true GH GY T0 GX (TMem TX TTop) n3 ->
    stp2 m false GH G1 T1 GX TX n2 ->
    stp2 m true GH G1 T1 G2 (TSel T2) (S (n0+n1+n2+n3))

(*
| stp2_bindI: forall G1 GX TX G2 x T2 v n1,
    index x G1 = Some v ->
    val_type0 GX v TX -> (* slack for: val_type G2 v T2 *)
    stp2 true GX TX G2 (open 0 (TVar x) T2) n1 ->
    stp2 true G1 (TVar x) G2 (TBind T2) (S n1)
*)

(*
| stp2_bindE: forall G1 G2 T2 x n1,
    stp2 true G1 (TVar x) G2 (TBind T2) n1 ->
    stp2 true G1 (TVar x) G2 (open 0 (TVar x) T2) (S n1)
*)

(*

| stp2_bind2: forall m GH G1 G2 T2 x n1,
    (* issue here: we want x.this < { z => T2 }
       and z:x.this |- *)

    stp2 m true GH G1 (TVar false x) G2 (open 0 (TVar false x) T2) n1 ->
    stp2 m true GH G1 (TVar false x) G2 (TBind T2) (S n1)

| stp2_bind1: forall m GH G1 G2 T1 T2 n1,
    closed (length GH) (length G2) 0 T2 ->
    stp2 m true ((G1,(open 0 (TVar false (length GH)) T1))::GH) G1 (TVar false (length GH)) G2 T2 n1 ->
    stp2 m true GH G1 (TBind T1) G2 T2 (S n1)

*)

(*
    x < T^x
    ----------------
    x < { z => T^z }

    T < { z => T^z }  T
    ----------------
    x < T^x

*)

| stp2_wrapf: forall m GH G1 G2 T1 T2 n1,
    stp2 m true GH G1 T1 G2 T2 n1 ->
    stp2 m false GH G1 T1 G2 T2 (S n1)
| stp2_transf: forall m GH G1 G2 G3 T1 T2 T3 n1 n2,
    stp2 m true GH G1 T1 G2 T2 n1 ->
    stp2 m false GH G2 T2 G3 T3 n2 ->
    stp2 m false GH G1 T1 G3 T3 (S (n1+n2))

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

with val_type0 : venv -> vl -> ty -> Prop :=
| v_bool: forall b,
    val_type0 [] (vbool b) TBool
| v_abs: forall venv tenv y T1 T2,
    wf_env venv tenv ->
    has_type (T1::(TFun T1 T2)::tenv) y T2 ->
    val_type0 venv (vabs venv y) (TFun T1 T2)
(* | v_var: forall venv x v,
    index x venv = Some v ->
    val_type0 venv v (TVar x) *)
| v_ty: forall venv T1,
    val_type0 venv (vty venv T1) (TMem T1 T1)

with val_type : venv -> vl -> ty -> Prop :=
| v_sub: forall G1 T1 G2 T2 v,
    val_type0 G1 v T1 ->
    (exists n, stp2 0 true [] G1 T1 G2 T2 n) ->
    val_type G2 v T2
.

Definition stpd2 m b GH G1 T1 G2 T2 := exists n, stp2 m b GH G1 T1 G2 T2 n.

Hint Constructors stp2.

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

Ltac eu := match goal with
             | H: stpd2 _ _ _ _ _ _ _ |- _ => destruct H as [? H]
           end.

Lemma stpd2_bot: forall m GH G1 G2 T,
    closed (length GH) (length G2) 0 T ->
    stpd2 m true GH G1 TBot G2 T.
Proof. intros. exists 1. eauto. Qed.
Lemma stpd2_top: forall m GH G1 G2 T,
    closed (length GH) (length G1) 0 T ->
    stpd2 m true GH G1 T G2 TTop.
Proof. intros. exists 1. eauto. Qed.
Lemma stpd2_bool: forall m GH G1 G2,
    stpd2 m true GH G1 TBool G2 TBool.
Proof. intros. exists 1. eauto. Qed.
Lemma stpd2_fun: forall m GH G1 G2 T1 T2 T3 T4,
    stpd2 m false GH G2 T3 G1 T1 ->
    stpd2 m false GH G1 T2 G2 T4 ->
    stpd2 m true  GH G1 (TFun T1 T2) G2 (TFun T3 T4).
Proof. intros. repeat eu. eexists. eauto. Qed.
Lemma stpd2_varx: forall m GH G1 G2 x1 x2 v,
    index x1 G1 = Some v ->
    index x2 G2 = Some v ->
    stpd2 m true GH G1 (TVar true x1) G2 (TVar true x2).
Proof. intros. repeat eu. exists 1. eauto. Qed.
Lemma stpd2_var1: forall m GH G1 GX TX G2 x T2 v,
    index x G1 = Some v ->
    val_type0 GX v TX -> (* slack for: val_type G2 v T2 *)
    stpd2 m true GH GX TX G2 T2 ->
    stpd2 m true GH G1 (TVar true x) G2 T2.
Proof. intros. repeat eu. eexists. eauto. Qed.
(*Lemma stpd2_var1b: forall m GH G1 GX TX G2 x x2 T2 v,
    index x G1 = Some v ->
    index x2 G2 = Some v ->
    val_type0 GX v TX -> (* slack for: val_type G2 v T2 *)
    stpd2 m true GH GX TX G2 (open 0 (TVar true x2) T2) ->
    stpd2 m true GH G1 (TVar true x) G2 (TBind T2).
Proof. intros. repeat eu. eexists. eauto. Qed.*)
Lemma stpd2_mem: forall m GH G1 G2 T1 T2 T3 T4,
    stpd2 m false GH G2 T3 G1 T1 ->
    stpd2 m true  GH G1 T2 G2 T4 ->
    stpd2 m true  GH G1 (TMem T1 T2) G2 (TMem T3 T4).
Proof. intros. repeat eu. eexists. eauto. Qed.
Lemma stpd2_sel: forall m GH G1 G2 T1 T2,
    stpd2 m false GH G2 T2 G1 T1 ->
    stpd2 m true  GH G1 T1 G2 T2 ->
    stpd2 m true  GH G1 (TSel T1) G2 (TSel T2).
Proof. intros. repeat eu. eexists. eauto. Qed.
Lemma stpd2_red: forall m GH G1 G2 T1 T2,
    stpd2 m true GH G1 T1 G2 (TMem TBot T2) ->
    stpd2 m true GH G1 (TSel T1) G2 T2.
Proof. intros. repeat eu. eexists. eauto. Qed.
Lemma stpd2_red2: forall m GH G1 G2 GX TX T1 T2 GY T0,
    real T0 ->
    stpd2 m true GH GY T0 G2 T2 ->
    stpd2 m false GH G2 T2 GX (TMem TX TTop) ->
    stpd2 m true GH GY T0 GX (TMem TX TTop) ->
    stpd2 m false GH G1 T1 GX TX ->
    stpd2 m true GH G1 T1 G2 (TSel T2).
Proof. intros. repeat eu. eexists. eauto. Qed.

(*
Lemma stpd2_bindI: forall G1 G2 T2 x,
    stpd2 true G1 (TVar x) G2 (open 0 (TVar x) T2) ->
    stpd2 true G1 (TVar x) G2 (TBind T2).
Proof. intros. repeat eu. eexists. eauto. Qed. *

Lemma stpd2_bindE: forall G1 G2 T2 x,
    stpd2 true G1 (TVar x) G2 (TBind T2) ->
    stpd2 true G1 (TVar x) G2 (open 0 (TVar x) T2).
Proof. intros. repeat eu. eexists. eauto. Qed.
*)

Lemma stpd2_bind1: forall m GH G1 G2 T1 T2,
    closed (length GH) (length G2) 0 T2 ->
    stpd2 m true ((G1,(open 0 (TVar false (length GH)) T1))::GH)
          G1 (TVar false (length GH)) G2 T2 ->
    stpd2 m true GH G1 (TBind T1) G2 T2.
Proof. intros. repeat eu. eexists. eauto. Qed.

Lemma stpd2_wrapf: forall m GH G1 G2 T1 T2,
    stpd2 m true GH G1 T1 G2 T2 ->
    stpd2 m false GH G1 T1 G2 T2.
Proof. intros. repeat eu. eexists. eauto. Qed.
Lemma stpd2_transf: forall m GH G1 G2 G3 T1 T2 T3,
    stpd2 m true GH G1 T1 G2 T2 ->
    stpd2 m false GH G2 T2 G3 T3 ->
    stpd2 m false GH G1 T1 G3 T3.
Proof. intros. repeat eu. eexists. eauto. Qed.

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

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

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

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

Hint Constructors has_type.
Hint Constructors stp2.
Hint Constructors val_type.
Hint Constructors wf_env.

Hint Unfold stpd2.

Hint Constructors option.
Hint Constructors list.

Hint Unfold index.
Hint Unfold length.

Hint Resolve ex_intro.

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

Lemma wf_length : forall vs ts,
                    wf_env vs ts ->
                    (length vs = length ts).
Proof.
  intros. induction H. auto.
  assert ((length (v::vs)) = 1 + length vs). constructor.
  assert ((length (t::ts)) = 1 + length ts). constructor.
  rewrite IHwf_env in H1. auto.
Qed.

Hint Immediate wf_length.

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.
  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_exists : forall X vs n,
                       n < length vs ->
                       exists (T:X), index n vs = Some T.
Proof.
  intros X vs. induction vs.
  Case "nil". intros. inversion H.
  Case "cons".
  intros. inversion H.
  SCase "hit".
  assert (beq_nat n (length vs) = true) as E. eapply beq_nat_true_iff. eauto.
  simpl. subst n. rewrite E. eauto.
  SCase "miss".
  assert (beq_nat n (length vs) = false) as E. eapply beq_nat_false_iff. omega.
  simpl. rewrite E. eapply IHvs. 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. reflexivity.
Qed.

Lemma closed_extend : forall T X (a:X) i k G,
                       closed i (length G) k T ->
                       closed i (length (a::G)) k T.
Proof.
  intros T. induction T; intros; inversion H;  econstructor; eauto.
  simpl. omega.
Qed.

Lemma stp2_extend : forall m b GH  v1 G1 G2 T1 T2 n,
                      stp2 m b GH G1 T1 G2 T2 n ->
                      stp2 m b GH (v1::G1) T1 G2 T2 n /\
                      stp2 m b GH G1 T1 (v1::G2) T2 n /\
                      stp2 m b GH (v1::G1) T1 (v1::G2) T2 n.
Proof.
  intros. induction H; try solve [repeat split; econstructor; try eauto;
          try eapply index_extend; eauto; try eapply closed_extend; eauto;
          try eapply IHstp2; eauto;
          try eapply IHstp2_1; try eapply IHstp2_2;
            try eapply IHstp2_3; try eapply IHstp2_4].
(*
  repeat split; eapply stp2_var1b. eapply index_extend; eauto. eauto. eauto.
  eauto. eauto. eapply index_extend; eauto. eauto. eapply IHstp2. eapply index_extend; eauto.
  eapply index_extend; eauto. eauto.
  eapply IHstp2.
*)
  admit. (* bind1 *)
  admit.
  admit.

  repeat split; eapply stp2_transf; try eapply IHstp2_1; eauto; try eapply IHstp2_2; eauto.
Qed.

Lemma stpd2_extend : forall m b GH v1 G1 G2 T1 T2,
                      stpd2 m b GH G1 T1 G2 T2 ->
                      stpd2 m b GH (v1::G1) T1 G2 T2 /\
                      stpd2 m b GH G1 T1 (v1::G2) T2 /\
                      stpd2 m b GH (v1::G1) T1 (v1::G2) T2.
Proof.
  intros. repeat eu. repeat split; eexists; eapply stp2_extend; eauto.
Qed.

Lemma stp2_extend1 : forall m b GH v1 G1 G2 T1 T2 n, stp2 m b GH G1 T1 G2 T2 n -> stp2 m b GH (v1::G1) T1 G2 T2 n.
Proof. intros. eapply stp2_extend. eauto. Qed.

Lemma stp2_extend2 : forall m b GH v1 G1 G2 T1 T2 n, stp2 m b GH G1 T1 G2 T2 n -> stp2 m b GH G1 T1 (v1::G2) T2 n.
Proof. intros. eapply stp2_extend. eauto. Qed.

Lemma stpd2_extend1 : forall m b GH v1 G1 G2 T1 T2, stpd2 m b GH G1 T1 G2 T2 -> stpd2 m b GH (v1::G1) T1 G2 T2.
Proof. intros. eapply stpd2_extend. eauto. Qed.

Lemma stpd2_extend2 : forall m b GH v1 G1 G2 T1 T2, stpd2 m b GH G1 T1 G2 T2 -> stpd2 m b GH G1 T1 (v1::G2) T2.
Proof. intros. eapply stpd2_extend. eauto. Qed.

Lemma stp_closed : forall G1 T1 T2,
                      stp G1 T1 T2 ->
                      closed (length G1) 0 0 T1 /\
                      closed (length G1) 0 0 T2.
Proof.
  intros. induction H; repeat split; try  econstructor; try eapply IHstp1; try eapply IHstp2; eauto; try eapply IHstp; eauto; try eapply index_max; eauto.
  destruct IHstp. inversion H1. eauto.
  destruct IHstp2. inversion H3. eauto.
Qed.

Lemma stpd2_closed : forall m b GH G1 G2 T1 T2,
                      stpd2 m b GH G1 T1 G2 T2 ->
                      closed (length GH) (length G1) 0 T1 /\
                      closed (length GH) (length G2) 0 T2.
Proof.
  admit. (*
  intros. eu. induction H; repeat split; try  econstructor; try eapply IHstp2_1; try eapply IHstp2_2; eauto; try eapply IHstp2; eauto; try eapply index_max; eauto.
  destruct IHstp2. inversion H1. eauto.
  eapply IHstp2_4. *)

Qed.

Lemma stpd2_closed1 : forall m b GH G1 G2 T1 T2,
                      stpd2 m b GH G1 T1 G2 T2 ->
                      closed (length GH) (length G1) 0 T1.
Proof. intros. eapply (stpd2_closed m b GH G1 G2); eauto. Qed.

Lemma stpd2_closed2 : forall m b GH G1 G2 T1 T2,
                      stpd2 m b GH G1 T1 G2 T2 ->
                      closed (length GH) (length G2) 0 T2.
Proof. intros. eapply (stpd2_closed m b GH G1 G2); eauto. Qed.

Lemma valtp_extend : forall vs v v1 T,
                       val_type vs v T ->
                       val_type (v1::vs) v T.
Proof.
  intros. induction H; econstructor; eauto; try eapply stpd2_extend; eauto; try eapply index_extend; eauto.
Qed.

Lemma index_safe_ex: forall H1 G1 TF i,
             wf_env H1 G1 ->
             index i G1 = Some TF ->
             exists v, index i H1 = Some v /\ val_type H1 v TF.
Proof. intros. induction H.
       Case "nil". inversion H0.
       Case "cons". inversion H0.
         case_eq (beq_nat i (length ts)).
           SCase "hit".
             intros E.
             rewrite E in H3. inversion H3. subst t.
             assert (beq_nat i (length vs) = true). eauto.
             assert (index i (v :: vs) = Some v). eauto.  unfold index. rewrite H2. eauto.
             eauto.
           SCase "miss".
             intros E.
             assert (beq_nat i (length vs) = false). eauto.
             rewrite E in H3.
             assert (exists v0, index i vs = Some v0 /\ val_type vs v0 TF) as HI. eapply IHwf_env. eauto.
           inversion HI as [v0 HI1]. inversion HI1.
           eexists. econstructor. eapply index_extend; eauto. eapply valtp_extend; eauto.
Qed.

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

Hint Constructors res_type.
Hint Resolve not_stuck.

Lemma stpd2_refl: forall m GH G1 T1,
  closed (length GH) (length G1) 0 T1 ->
  stpd2 m true GH G1 T1 G1 T1.
Proof.
  intros. induction T1; inversion H.
  - Case "bot". exists 1. eauto.
  - Case "top". exists 1. eauto.
  - Case "bool". eapply stpd2_bool; eauto.
  - Case "fun". eapply stpd2_fun; try eapply stpd2_wrapf; eauto.
  - Case "var0". exists 1. eauto.
  - Case "var1".
    assert (exists v, index i G1 = Some v) as E. eapply index_exists; eauto.
    destruct E.
    eapply stpd2_varx; eauto.
  - Case "varb". inversion H4.
  - Case "mem". eapply stpd2_mem; try eapply stpd2_wrapf; eauto.
  - Case "sel". eapply stpd2_sel; try eapply stpd2_wrapf; eauto.
  - Case "bind".
    eapply stpd2_bind1. eauto. exists 2.
    eapply stp2_bind2.
    simpl. eauto.

    eapply stp2_vara1. simpl. rewrite <-beq_nat_refl. eauto.

    (* TODO:
       stp2 m true ((G1, open 0 (TVar false (length GH)) T1) :: GH) G1
     (open 0 (TVar false (length GH)) T1) G1
     (open 0 (TVar false (length GH)) T1) 0
     *)

    admit.
Qed.

Lemma stpd2_reg1 : forall m b GH G1 G2 T1 T2,
                      stpd2 m b GH G1 T1 G2 T2 ->
                      stpd2 m true GH G1 T1 G1 T1.
Proof.
  intros. eapply stpd2_refl. eapply (stpd2_closed m b GH G1 G2). eauto.
Qed.

Lemma stpd2_reg2 : forall m b GH G1 G2 T1 T2,
                      stpd2 m b GH G1 T1 G2 T2 ->
                      stpd2 m true GH G2 T2 G2 T2.
Proof.
  intros. eapply stpd2_refl. eapply (stpd2_closed m b GH G1 G2). eauto.
Qed.

(*

Lemma invert_bind1: forall n, forall venv vf T1 GX TX n1,
  val_type0 GX vf TX -> stp2 true GX TX venv (TBind T1) n1 -> n1 < n ->
  exists x n2,
    index x venv = Some vf ->
    n2 < n1 ->
    stp2 true GX TX venv (open 0 (TVar x) T1) n2.
Proof.
  intros n. induction n; intros. solve by inversion.
  inversion H; subst.
  - Case "bool". solve by inversion.
  - Case "fun". solve by inversion.
(*   - Case "var". subst. inversion H0; subst.
    + SCase "normal".
    assert (vf = v) as A. rewrite H2 in H4. inversion H4. eauto.
    rewrite A. assert (n0 < n) as B. omega.
    specialize (IHn venv0 v T1 GX0 TX n0 H5 H6 B).
    ev. repeat eexists; eauto.
  (* repeat eapply IHn; eauto. omega. *)
    + SCase "bindE". eauto.
    + eauto.      *)
  - Case "mem". solve by inversion.
Qed.
*)

Lemma invert_mem1: forall n, forall venv m GH vf T1 T2 GX TX n1,
  val_type0 GX vf TX -> stp2 m true GH GX TX venv (TMem T1 T2) n1 -> n1 < n ->
  exists env T3 n2 n3,
    vf = (vty env T3) /\
    (n2 + n3) < n /\
    stp2 m false GH venv T1 env T3 n2 /\
    stp2 m true GH env T3 venv T2 n3.
Proof.
  intros n. induction n; intros. solve by inversion.
  inversion H; subst.
  - Case "bool". solve by inversion.
  - Case "fun". solve by inversion.
(*  - Case "var". subst. inversion H0; subst.
    + SCase "normal".
    assert (vf = v) as A. rewrite H2 in H4. inversion H4. eauto.
    rewrite A. assert (n0 < n) as B. omega.
    specialize (IHn venv0 v T1 T2 GX0 TX n0 H5 H6 B).
    ev. repeat eexists; eauto.
  (* repeat eapply IHn; eauto. omega. *)
    + SCase "bindE".
      destruct T0; simpl in H6; try destruct i; inversion H6.
*)
  - Case "mem". inversion H0. subst. repeat eexists; eauto. omega.
Qed.

(*
Lemma invert_mem: forall venv vf T1 T2,
  val_type venv vf (TMem T1 T2) ->
  exists env T3,
    vf = (vty env T3) /\
    stpd2 false venv T1 env T3 /\
    stpd2 true env T3 venv T2.
Proof.
  intros. inversion H. ev. assert (x < S x) as E. omega.
  specialize (invert_mem1 (S x) venv0 vf T1 T2 G1 T0 x H0 H1 E). intros IH.
  ev. repeat eexists; eauto.
Qed.
*)

Lemma stpd2_trans_axiom_aux: forall n, forall m GH G1 G2 G3 T1 T2 T3 n1,
  stp2 m false GH G1 T1 G2 T2 n1 -> n1 < n ->
  stpd2 m false GH G2 T2 G3 T3 ->
  stpd2 m false GH G1 T1 G3 T3.
Proof.
  intros n. induction n; intros; try omega; repeat eu; subst; inversion H; clear H; subst.
  - Case "wrapf". eapply stpd2_transf. eexists. eauto. eexists. eauto.
  - Case "transf". eapply stpd2_transf. eexists. eauto. eapply IHn. eauto. omega. eexists. eauto.
Qed.

Lemma stp2_trans_axiom: forall m b GH G1 G2 G3 T1 T2 T3,
  stpd2 m b GH G1 T1 G2 T2 ->
  stpd2 m false GH G2 T2 G3 T3 ->
  stpd2 m false GH G1 T1 G3 T3.
Proof.
  intros. destruct b; eu; eu; eapply stpd2_trans_axiom_aux; 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.

Ltac invty := match goal with
                | H1: TBot     = _ |- _ => inversion H1
                | H1: TBool    = _ |- _ => inversion H1
                | H1: TSel _   = _ |- _ => inversion H1
                | H1: TMem _ _ = _ |- _ => inversion H1
                | H1: TVar _ _ = _ |- _ => inversion H1
                | H1: TFun _ _ = _ |- _ => inversion H1
                | H1: TBind  _ = _ |- _ => inversion H1
                | _ => idtac
              end.

Ltac invstp_var := match goal with
  | H1: stp2 _ true _ _ TBot        _ (TVar _ _) _ |- _ => inversion H1
  | H1: stp2 _ true _ _ TTop        _ (TVar _ _) _ |- _ => inversion H1
  | H1: stp2 _ true _ _ TBool       _ (TVar _ _) _ |- _ => inversion H1
  | H1: stp2 _ true _ _ (TFun _ _)  _ (TVar _ _) _ |- _ => inversion H1
  | H1: stp2 _ true _ _ (TMem _ _)  _ (TVar _ _) _ |- _ => inversion H1
  | H1: val_type0 _ _ _ |- _ => inversion H1
  | _ => idtac
end.

(*
Lemma stp2_substitute_aux: forall ni nj, forall d m G1 G2 T1 T2 GH n1,
   stp2 (S d) m G1 T1 G2 T2 GH n1 -> n1 < nj ->
   forall GH0 GH0' GX TX TX' l T1' T2' V,
     GH = (GH0 ++ [(0,(GX, TX))]) ->
     val_type GX V (subst TX' TX) ni ->
     (* When we're replacing binds from a pack/unpack sequence, the
        type in GH may refer to itself (contain TSelH 0).
        It should be safe for TX to refer to itself. *)
     closed 0 1 TX ->
     closed 0 0 (TSel TX' l) ->
     compat GX TX TX' (Some V) G1 T1 T1' ->
     compat GX TX TX' (Some V) G2 T2 T2' ->
     Forall2 (compat2 GX TX TX' (Some V)) GH0 GH0' ->
     compat GX TX TX' (Some V) GX TX (subst TX' TX) ->
     exists n1', stp2 (S d) m G1 T1' G2 T2' GH0' n1'.
*)

Lemma stp2_subst: forall m b G1 G2 T1 T2 GX TX n1,
   stp2 m b [(GX,TX)] G1 T1 G2 T2 n1 ->
   stpd2 m b nil G1 T1 G2 T2.
Proof.
  admit.
Qed.

Lemma stp2_narrow: forall m GX1 GX2 TX1 TX2 G1 G2 T1 T2 n1 n2,
  stp2 m true [(GX1,TX1)] GX1 TX1 GX2 TX2 n1 ->
  stp2 m true [(GX2,TX2)] G1 T1 G2 T2 n2 ->
  stpd2 m true [(GX1,TX1)] G1 T1 G2 T2.
Proof.
  admit.
Qed.

Lemma stp2_trans: forall n, forall m b G1 G2 G3 T1 T2 T3 n1 n2,
  stp2 m b nil G1 T1 G2 T2 n1 ->
  stp2 m true nil G2 T2 G3 T3 n2 ->
  n1 < n ->
  stpd2 m true nil G1 T1 G3 T3.
Proof.
  intros n. induction n; intros. solve by inversion.
  inversion H.
  - Case "bot". eapply stpd2_bot; eauto. eapply stpd2_closed2; eauto.
  - Case "top". inversion H0; subst; invty.
    + SCase "top". eapply stpd2_top; eauto.
    + SCase "red2". eapply stpd2_red2. eauto. eauto. eauto. eauto. eapply stp2_trans_axiom; eauto.
(*    + SCase "bind2". invstp_var. *)
  - Case "bool". inversion H0; subst; invty.
    + SCase "top". eapply stpd2_top; eauto. econstructor.
    + SCase "bool". eapply stpd2_bool; eauto.
    + SCase "red2". eapply stpd2_red2. eauto. eauto. eauto. eauto. eapply stp2_trans_axiom; eauto.
  - Case "fun". inversion H0; subst; invty.
    + SCase "top". eapply stpd2_top; eauto. eapply stpd2_closed1; eauto.
    + SCase "fun". invty. subst. eapply stpd2_fun; eapply stp2_trans_axiom; eauto.
    + SCase "red2". eapply stpd2_red2. eauto. eauto. eauto. eauto. eapply stp2_trans_axiom; eauto.
  - Case "varx". inversion H0; subst; invty.
    + SCase "top". eapply stpd2_top; eauto. eapply stpd2_closed1; eauto.
    + SCase "varx". invty. subst. index_subst. eapply stpd2_varx; eauto.
    + SCase "var1". invty. subst. index_subst. eapply stpd2_var1; eauto.
    + SCase "var1b". admit. (* invty. subst. index_subst. eexists. eapply stp2_var1b; eauto. *)
    + SCase "red2". eapply stpd2_red2. eauto. eauto. eauto. eauto. eapply stp2_trans_axiom; eauto.
  - Case "var1".
    eapply stpd2_var1; eauto. eapply IHn; eauto. omega.
  - Case "var1b". inversion H0; subst; invty.
    + SCase "top". eapply stpd2_top; eauto. eapply stpd2_closed; eauto.
    + SCase "red2". eapply stpd2_red2. eauto. eauto. eauto. eauto. eapply stp2_trans_axiom; eauto.
    + SCase "bind1".
      subst.
      assert (stpd2 m true [(G1, TVar true x)] G2
                    (TVar false (length ([]:aenv))) G3 T3) as NRW.
      eapply stp2_narrow. eapply stp2_var1. eauto. eauto. eauto. eauto.

      assert (stpd2 m true [(G1, TVar true x)] G2
                    (TVar false (length ([]:aenv))) G3 T3) as NRW.

      eapply stpd2_var1. eauto. eauto. eapply IHn.

      (*
         stp2 m true GH
          GX TX
          G2 (open 0 (TVar true x2) T0) n0

         stp2 m true ((G2, open 0 (TVar false (length GH)) T0) :: GH)
          G2 (TVar false (length GH))
          G3 T3 n3
      *)

      admit.
    + SCase "bind1".
      admit.

  - Case "mem". inversion H0; subst; invty.
    + SCase "top". eapply stpd2_top; eauto. eapply stpd2_closed1; eauto.
    + SCase "mem". subst. eapply stpd2_mem. eapply stp2_trans_axiom; eauto. eapply IHn; eauto; try omega.
    + SCase "red2". eapply stpd2_red2. eauto. eauto. eauto. eauto. eapply stp2_trans_axiom; eauto.
    + SCase "bind2". invstp_var.
  - Case "sel". inversion H0; subst; invty.
    + SCase "top". eapply stpd2_top; eauto. eapply stpd2_closed1; eauto.
    + SCase "sel". subst. eapply stpd2_sel. eapply stp2_trans_axiom; eauto. eapply IHn; eauto; try omega.
    + SCase "red". subst. eapply stpd2_red. eapply IHn. eauto. eauto. omega.
    + SCase "red2". subst. eapply stpd2_red2. eauto. eauto. eauto. eauto. eapply stp2_trans_axiom; eauto.
    + SCase "bind2". invstp_var.
  - Case "red".
    eapply stpd2_red. eauto. eapply IHn; eauto. repeat econstructor. eauto. omega.
  - Case "red2".
    inversion H0; subst; invty.
    + SCase "top". eapply stpd2_top; eauto. eapply stpd2_closed1; eauto.
    + SCase "sel". subst.
      eapply stpd2_red2. eauto.
      eapply IHn. eapply H3. eauto. omega. eapply stp2_trans_axiom; eauto. eauto. eauto.
    + SCase "red". clear H. subst.
      (* pull this out as stp2_trans_cross lemma? *)

      assert (stp2 m true GH GY T5 G2 T4 n0) as A0. eauto.
      assert (stp2 m true GH GY T5 GX (TMem TX TTop) n5) as A1. eauto.
      assert (stpd2 m true GH GY T5 G3 (TMem TBot T3)) as A2. eapply IHn. eapply A0. eauto. omega. eu.

      destruct H2; inversion A1; inversion A2; subst. (* could pull out into a lemma: invert_real *)
      * SSCase "var".
        index_subst.

        assert (exists GX1 TX1 m1 m2, v0 = (vty GX1 TX1) /\ m1 + m2 < S n1 /\
          stp2 m false GH GX TX GX1 TX1 m1 /\ stp2 m true GH GX1 TX1 GX TTop m2) as B1.
        eapply invert_mem1. eapply H7. eauto. eauto.

        assert (exists GX2 TX2 m3 m4, v0 = (vty GX2 TX2) /\ m3 + m4 < S n2 /\
          stp2 m false GH G3 TBot GX2 TX2 m3 /\ stp2 m true GH GX2 TX2 G3 T3 m4) as B2.
        eapply invert_mem1. eapply H18. eauto. eauto.

        destruct B1 as [GZ1 [TZ1 [m1 [m2 [V1 [M1 [B1 _]]]]]]].
        destruct B2 as [GZ2 [TZ2 [m3 [m4 [V2 [M2 [_ B2 ]]]]]]].

        subst v0. inversion V2. subst.

        assert (stpd2 m true GH GX TX G3 T3) as S3. eapply IHn. eapply B1. eapply B2. omega. eu.
        assert (stpd2 m true GH G1 T1 G3 T3) as S1. eapply IHn. eauto. eapply S3. omega.
        eapply S1.

      * SSCase "mem".

        assert (stp2 m false GH GX TX GY T n2) as B1. eauto.
        assert (stp2 m true GH GY T G3 T3 n7) as B2. eauto.

        assert (stpd2 m true GH GX TX G3 T3) as S3. eapply IHn. eapply B1. eapply B2. omega. eu.
        assert (stpd2 m true GH G1 T1 G3 T3) as S1. eapply IHn. eauto. eapply S3. omega.
        eapply S1.

    + SCase "red2". eapply stpd2_red2. eauto. eauto. eauto. eauto. eapply stp2_trans_axiom; eauto.

    + SCase "bind2". invstp_var.

  - Case "bind2".
    inversion H0; subst; invty.
    + SCase "top". eapply stpd2_top; eauto.
    + SCase "red2". eapply stpd2_red2; eauto.
    + SCase "bind2". invstp_var.
    + SCase "bind".
      (* cross, between v and v0 *)
      assert (stp2 m true GH G1 T1 (v :: G2) (TVar (length G2)) n0) as ST. assumption.
      (* to be narrowed *)
      assert (stp2 m true GH (v0 :: G2) (TVar (length G2)) G3 T3 n3) as A1. assumption.
      (* narrowed *)
      assert (stp2 m true GH (v :: G2) (TVar (length G2)) G3 T3 n3) as A2. admit.
      (* result *)
      eapply IHn. eauto. eauto. omega.

  - Case "bind1". subst.
    eapply stpd2_bind1. eapply stpd2_closed2; eauto. eauto. eapply IHn; eauto. omega.

  - Case "wrapf".
    subst. eapply IHn. eapply H2. eapply H0. omega.
  - Case "transf".
    assert (stpd2 m true GH G4 T4 G3 T3). eapply IHn. eapply H3. eapply H0. omega.
    eu. subst. eapply IHn. eapply H2. eauto. omega.
Grab Existential Variables.
apply 0. apply 0. apply []. apply 0.
Qed.

(* idea: can we use the same strong_sel as before, and just translate the new rules? *)

Lemma stpd2_trans: forall m b GH G1 G2 G3 T1 T2 T3,
  stpd2 m b GH G1 T1 G2 T2 ->
  stpd2 m true GH G2 T2 G3 T3 ->
  stpd2 m true GH G1 T1 G3 T3.
Proof.
  intros. repeat eu. eapply stp2_trans; eauto.
Qed.

Lemma invert_var1: forall n, forall venv v x GX TX n1,
  val_type0 GX v TX -> stp2 true GX TX venv (TVar x) n1 -> n1 < n ->
  index x venv = Some v.
Proof.
  intros n. induction n; intros. solve by inversion.
  inversion H; subst.
  - Case "bool". solve by inversion.
  - Case "fun". solve by inversion.
  - Case "var". subst. inversion H0; subst.
    + SCase "varx".
      assert (v = v0) as A. rewrite H2 in H5. inversion H5. eauto.
      rewrite A. eauto.
    + SCase "var1".
      assert (v = v0) as A. rewrite H2 in H4. inversion H4. eauto.
      rewrite A. eapply IHn; eauto. omega.
  - Case "mem". solve by inversion.
Qed.

Lemma invert_var: forall venv v x,
  val_type venv v (TVar x) ->
  index x venv = Some v.
Proof.
  intros. inversion H. ev. eapply invert_var1; eauto.
Qed.

Lemma stp_to_stpd2: forall G1 T1 T2,
  stp G1 T1 T2 ->
  forall GX, wf_env GX G1 ->
  stpd2 true GX T1 GX T2.
Proof.
  intros G1 T1 T2 H. induction H; intros.
  - Case "bool". eapply stpd2_bool; eauto.
  - Case "fun".  eapply stpd2_fun; eapply stpd2_wrapf; eauto.
  - Case "varx".
    assert (exists v, index x GX = Some v) as E. eapply index_exists. rewrite (wf_length GX G1). eauto. eauto.
    destruct E.
    eapply stpd2_varx; eauto.
  - Case "vary".
    assert (exists v, index x GX = Some v /\ val_type GX v (TVar y)) as E. eapply index_safe_ex; eauto.
    destruct E. destruct H2. inversion H3. subst.
    eapply stpd2_varx. eapply invert_var. eauto. eauto.
  - Case "var1".
    assert (exists v, index x GX = Some v /\ val_type GX v T1) as E. eapply index_safe_ex; eauto.
    destruct E. destruct H2. destruct H3.
    eapply stpd2_var1. eauto. eauto. eauto.
  - Case "mem". eapply stpd2_mem; try eapply stpd2_wrapf; eauto.
  - Case "sel". eapply stpd2_sel; eauto; try eapply stpd2_wrapf; eauto.
  - Case "red". eapply stpd2_red. eauto.
  - Case "red2". eapply stpd2_red2. eauto.
    eapply IHstp1. eauto. eapply stpd2_wrapf.
    eapply IHstp2. eauto.
    eapply stpd2_trans. eapply IHstp1. eauto. eapply IHstp2. eauto.
    assert (closed (length G1) (TMem T1 TTop)) as C. eapply stp_closed; eauto.
    eapply stpd2_wrapf. eapply stpd2_refl. rewrite (wf_length GX G1). inversion C. eauto. eauto.
Qed.

Lemma valtp_widen: forall vf H1 H2 T1 T2,
  val_type H1 vf T1 ->
  stpd2 true H1 T1 H2 T2 ->
  val_type H2 vf T2.
Proof.
  intros.  inversion H.
  - econstructor; eauto. eapply stpd2_trans; eauto.
Qed.

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

Lemma invert_abs1: forall n, forall venv vf T1 T2 GX TX n1,
  val_type0 GX vf TX -> stp2 true GX TX venv (TFun T1 T2) n1 -> n1 < n ->
  exists env tenv y T3 T4,
    vf = (vabs env y) /\
    wf_env env tenv /\
    has_type (T3::(TFun T3 T4)::tenv) y T4 /\
    stpd2 true venv T1 env T3 /\
    stpd2 true env T4 venv T2.
Proof.
  intros n. induction n; intros. solve by inversion.
  inversion H; subst.
  - Case "bool". solve by inversion.
  - Case "fun". subst. inversion H0. subst.
    eexists. eexists. eexists. eexists. eexists. repeat split; eauto.
    eapply stpd2_trans. eauto. eapply stpd2_reg2. eauto.
    eapply stpd2_trans. eauto. eapply stpd2_reg2. eauto.
  - Case "var". subst. inversion H0. subst.
    assert (vf = v) as A. rewrite H2 in H4. inversion H4. eauto.
    rewrite A. eapply IHn; eauto. omega.
  - Case "mem". solve by inversion.
Qed.

Lemma invert_abs: forall venv vf T1 T2,
  val_type venv vf (TFun T1 T2) ->
  exists env tenv y T3 T4,
    vf = (vabs env y) /\
    wf_env env tenv /\
    has_type (T3::(TFun T3 T4)::tenv) y T4 /\
    stpd2 true venv T1 env T3 /\
    stpd2 true env T4 venv T2.
Proof.
  intros. inversion H. ev. eapply invert_abs1; eauto.
Qed.

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

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

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

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

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

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

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

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

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

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

      assert (res_type (vx::vf::env1) res T4) as HRY.
        SCase "HRY".
          subst. eapply IHn. eauto. eauto.
          (* wf_env f x *) econstructor. eapply valtp_widen; eauto. eapply stpd2_extend2; eauto. eapply stpd2_extend2; eauto.
          (* wf_env f   *) econstructor. eapply v_sub. eapply v_abs; eauto. eapply stpd2_extend2. eapply stpd2_fun. eapply stpd2_wrapf. eapply stpd2_reg2; eauto. eapply stpd2_wrapf. eapply stpd2_reg1; eauto.
          eauto.

      inversion HRY as [? vy].

      eapply not_stuck. eapply valtp_widen; eauto. eapply stpd2_extend1. eapply stpd2_extend1. eauto.

    + eapply restp_widen. eapply IHhas_type; eauto. eapply stp_to_stpd2; eauto.

  - Case "Abs".
    remember (tabs e) as xe. induction H0; inversion Heqxe; subst.
    + eapply not_stuck. eapply v_sub. eapply v_abs; eauto. eapply stpd2_refl. rewrite (wf_length venv0 env). eauto. eauto.
    + eapply restp_widen. eapply IHhas_type; eauto. eapply stp_to_stpd2; eauto.

Grab Existential Variables.
apply 0. apply 0.
Qed.

End STLC.


Require Export Iron.Language.SystemF2Effect.Type.Exp.Base.
Require Export Iron.Language.SystemF2Effect.Type.Operator.FlattenT.
Require Export Iron.Language.SystemF2Effect.Type.Relation.KindT.
Require Export Iron.Language.SystemF2Effect.Type.Relation.KindTs.
Require Export Iron.Language.SystemF2Effect.Type.Relation.EquivT.
Require Export Iron.Language.SystemF2Effect.Type.Relation.EquivTs.

(********************************************************************)
Fixpoint bunchT (k : ki) (tt : list ty) : ty
 := match tt with
    | nil           => TBot k
    | t :: ts       => TSum t (bunchT k ts)
    end.

(********************************************************************)
Lemma bunchT_kindT
 :  forall ke sp ts k
 ,  SumKind k
 -> KindTs ke sp ts k
 -> KindT  ke sp (bunchT k ts) k.
Proof.
 intros.
 induction ts.
 - simpl. eauto.
 - inverts H0.
   eapply KiSum; eauto.
Qed.
Hint Resolve bunchT_kindT.

Lemma bunchT_kindTs
 :  forall ke sp ts k
 ,  KindT  ke sp (bunchT k ts) k
 -> KindTs ke sp ts k.
Proof.
 intros.
 induction ts.
 - auto.
 - unfold KindTs.
   snorm.
   inverts H0.
   + inverts H. auto.
   + inverts H. rip.
     unfold KindTs in *. snorm.
Qed.
Hint Resolve bunchT_kindTs.

Lemma bunchT_singleton
 :  forall ke sp t k
 ,  SumKind k
 -> KindT ke sp t k
 -> EquivT ke sp (bunchT k (t :: nil)) t k.
Proof.
 intros.
 simpl.
 eapply EqSym.
  auto.
  auto.
  eapply EqSumBot; auto.
Qed.

Lemma bunchT_sum
 :  forall ke sp ts1 ts2 k
 ,  SumKind k
 -> KindTs ke sp ts1 k
 -> KindTs ke sp ts2 k
 -> EquivT ke sp (bunchT k (ts2 >< ts1))
                 (TSum (bunchT k ts1) (bunchT k ts2)) k.
Proof.
 intros.
 induction ts1.
 - simpl.
   eapply EqSym; auto.
 - have (KindTs ke sp ts1 k). rip.
   have (KindT  ke sp a   k).
   simpl.
   eapply EqTrans
    with (t2 := TSum a (TSum (bunchT k ts1) (bunchT k ts2))).
   + eapply EqSumCong; auto.
   + eapply EqSumAssoc; auto.
Qed.
Hint Resolve bunchT_sum.

Lemma bunchT_flattenT_sum
 :  forall ke sp k t1 t2
 ,  SumKind k
 -> EquivT ke sp (bunchT k (flattenT t1)) t1 k
 -> EquivT ke sp (bunchT k (flattenT t2)) t2 k
 -> EquivT ke sp (bunchT k (flattenT t2 >< flattenT t1)) (TSum t1 t2) k.
Proof.
 intros.
 eapply EqTrans.
 - eapply bunchT_sum; eauto.
 - eapply EqSumCong; eauto.
Qed.

Lemma bunchT_flattenT
 :  forall ke sp t k
 ,  SumKind k
 -> KindT   ke sp t k
 -> EquivT  ke sp (bunchT k (flattenT t)) t k.
Proof.
 induction t; intros; simpl; snorm.

 - Case "TSum".
   inverts H0.
   spec IHt1 k.
   spec IHt2 k.
   rip.
   eapply bunchT_flattenT_sum; auto.

 - Case "TBot".
   inverts H0. eauto.
Qed.
Hint Resolve bunchT_flattenT.

(* The converse is not true.
   If 'ts' contains  '(TSum t1 t2)'  this will be eliminated
   by 'flattenT . bunchT', then the EqsSum check fails.
Lemma flattenT_bunchT
 :  forall  ke sp ts k
 ,  SumKind k
 -> KindTs  ke sp ts k
 -> EquivTs ke sp (flattenT (bunchT k ts)) ts k.
*)


Axiom Ω : Type.
Axiom R : Ω -> Ω -> Type.

Definition Θ : Ω -> Ω -> Type :=
  fun p q => forall r, R p r -> R q r.

Definition refl : forall p, Θ p p := fun p r k => k.
Definition trns : forall p q r, Θ p q -> Θ q r -> Θ p r := fun p q r θ₁ θ₂ s k =>
  θ₂ _ (θ₁ _ k).

Notation "α ∘ β" := (trns _ _ _ α β) (at level 35).

Goal forall (p : Ω) (q : Ω) (α : Θ q p)
  (A : forall (r : Ω) (β : Θ r q), Type)
  (x : forall (r : Ω) (β : Θ r q), A r β), A q (refl q).
Proof.
refine (
  fun p q α A x => x q (refl q)
).
Abort.

Set Universe Polymorphism.
Set Primitive Projections.

Record sigT (A : Type) (P : A -> Type) : Type := exist {
  fst : A;
  snd : P fst;
}.

Arguments fst {_ _} _.
Arguments snd {_ _} _.

Notation "{ x : A  & P }" := (sigT A (fun x => P)) : type_scope.

Definition Typeᵒ p := forall (q : Ω) (α : Θ q p), Type.
Definition Typeᴿ p (A : Typeᵒ p) := {
    Aε :
      forall (q : Ω) (α : Θ q p),
        (forall (r : Ω) (β : Θ r q), A r (β ∘ α)) -> Type
    &
      forall (q : Ω) (α : Θ q p),
      forall (x : forall r (β : Θ r q), A r (β ∘ α)),
        Aε q α x ->
        forall (r : Ω) (β : Θ r q),
        Aε r (β ∘ α) (fun s γ => x s (γ ∘ β))
}.

Definition TYPE p := {A : Typeᵒ p & Typeᴿ p A}.
Definition El p (A : TYPE p) :=
  { x : forall (q : Ω) (α : Θ q p), A.(fst) q α & A.(snd).(fst) p (refl p) x }.

Definition Typeᶱ : forall p (A : Typeᵒ p) (Aε : Typeᴿ p A) q (α : Θ q p),
  Typeᴿ q (fun r β => A r (β ∘ α)).
Proof.
unshelve refine (fun p A Aε q α => exist _ _ _ _).
+ refine (fun r β x => Aε.(fst) r (β ∘ α) x).
+ refine (fun r β x xε s γ => _).
  refine (Aε.(snd) r (β ∘ α) x xε s γ).
Defined.

Definition Type0 p : TYPE p.
Proof.
unshelve refine (
  exist (Typeᵒ p) (Typeᴿ p) (fun q α => Type) (exist _ _ (fun q α => Typeᴿ q) _)
).
refine (fun q α A Aε r β => Typeᶱ q A Aε r β).
Defined.

Definition Typeᶠ p : El p (Type0 p) := Type0 p.

Definition TYPEᶱ p (A : TYPE p) q (α : Θ q p) : TYPE q :=
  exist (Typeᵒ q) (Typeᴿ q) (fun r β => A.(fst) r (β ∘ α)) (Typeᶱ p A.(fst) A.(snd) q α).

Definition θ {p} {A : TYPE p} (x : El p A) {q} (α : Θ q p) : El q (TYPEᶱ p A q α).
Proof.
unshelve refine (exist _ _ _ _).
+ refine (fun r β => x.(fst) r (β ∘ α)).
+ refine (A.(snd).(snd) p (refl p) x.(fst) x.(snd) q α).
Defined.

Goal forall (p : Ω),
  { f : (forall (q : Ω) (α : Θ q p)
    (A : Typeᵒ q)
    (Aε : Typeᴿ q A)
    (x : forall (r : Ω) (β : Θ r q), A r β)
    (xε : Aε.(fst) q (refl q) x),
    A q (refl q))
  &
    forall
    (A : Typeᵒ p)
    (Aε : Typeᴿ p A)
    (x : forall (r : Ω) (β : Θ r p), A r β)
    (xε : Aε.(fst) p (refl p) x),
    Aε.(fst) p (refl p)
      (fun q α => f q α
          (fun r β => A r (β ∘ α))
          (Typeᶱ _ A Aε _ _)
          (fun r β => x r (β ∘ α))
          (Aε.(snd) _ _ _ xε _ _)
      )
  }.
Proof.
unshelve refine (fun p => exist _ _ _ _).
refine (
  fun q α A Aε x xε => x q (refl q)
).
cbn.
refine (
  fun A Aε x xε => xε
).
Defined.

Definition Arrowᵒ p (q : Ω) (α : Θ q p) (A : TYPE q) (B : TYPE q) : Type :=
  forall x : El q A, B.(fst) q (refl q).

Definition Arrowᴿ p (q : Ω) (α : Θ q p) (A : TYPE q) (B : TYPE q) :
  Typeᴿ q (fun r β => Arrowᵒ p r (β ∘ α) (TYPEᶱ q A r β) (TYPEᶱ q B r β)).
Proof.
unshelve refine (exist _ _ _ _); cbn in *.
  - unshelve refine
    (fun r β f =>
      forall
        (s : Ω) (γ : Θ s r) (x : El s (TYPEᶱ q A s (γ ∘ β))),
        B.(snd).(fst) s (γ ∘ β) (fun t δ => f t (δ ∘ γ) (θ x δ))
    ).
  - unshelve refine (fun r β f fε s γ t δ x => fε _ _ _).
Defined.

Definition Arrow0 p (A : El p (Typeᶠ p)) (B : El p (Typeᶠ p)) : El p (Typeᶠ p).
Proof.
unshelve refine (exist _ _ _ _).
+ refine (fun q α => Arrowᵒ p q α (θ A α) (θ B α)).
+ refine (Arrowᴿ p p (refl p) A B).
Defined.

(*
Definition Arrowᶠ p :
  { T :
    forall (q : Ω) (α : Θ q p)
    (A : TYPE q)
    (B : TYPE q),
    Type
  & forall (q : Ω) (α : Θ q p)
    (A : TYPE q)
    (B : TYPE q),
    Typeᴿ q (fun r β => T r (β ∘ α) (TYPEᶱ q A r β) (TYPEᶱ q B r β)) }
.
Proof.
unshelve refine (exist _ _ _ _).
+ refine (Arrowᵒ p).
+ refine (fun q α => Arrowᴿ q q (refl _)).
Defined.*)

(* Notation "A →ᶠ B" := (Arrowᶠ A (fun _ => B)) (at level 99, right associativity, B at level 200). *)

(* Check (fun p => Arrowᶠ p) : forall p, El p (Arrowᶠ p Typeᶠ. *)

(**

Definition Arrowᵒ p
  (q : Ω) (α : Θ q p)
  (A : Typeᵒ q)
  (Aε : Typeᴿ q A)
  (B : Typeᵒ q)
  (Bε : Typeᴿ q B)
  : Type.
Proof.
refine (
  forall
    (x : (forall r (β : Θ r q), A r β))
    (xε : Aε.(fst) q (refl q) x),
    B q (refl q)
).
Defined.

Definition Arrowᴿ p
  (q : Ω) (α : Θ q p)
  (A : Typeᵒ q)
  (Aε : Typeᴿ q A)
  (B : Typeᵒ q)
  (Bε : Typeᴿ q B)
  : Typeᴿ q (fun r β =>
    Arrowᵒ q r β
      (fun s γ => A s (γ ∘ β))
      (Typeᶱ _ A Aε _ _)
      (fun s γ => B s (γ ∘ β))
      (Typeᶱ _ B Bε _ _)
  ).
Proof.
unshelve refine (exist _ _ _ _); unfold Arrowᵒ; cbn in *.
+ unshelve refine
  (fun r β f =>
    forall
      (s : Ω) (γ : Θ s r)
      (x : (forall t δ, A t (δ ∘ γ ∘ β)))
      (xε : Aε.(fst) s (γ ∘ β) x),
      Bε.(fst) s (γ ∘ β)
        (fun t δ => f t (δ ∘ γ) (fun u ε => x u (ε ∘ δ)) (Aε.(snd) s (γ ∘ β) x xε t δ))
  ).
+ unshelve refine (fun r β f fε s γ t δ x xε => fε _ _ _ _).
Defined.

Definition Prodᵒ p
  (q : Ω) (α : Θ q p)
  (A : Typeᵒ q)
  (Aε : Typeᴿ q A)
  (B : forall (r : Ω) (β : Θ r q)
    (x : forall (s : Ω) (γ : Θ s r), A s (γ ∘ β))
    (xε : Aε.(fst) r _ x), Type)
  (Bε : forall (r : Ω) (β : Θ r q)
    (x : forall (s : Ω) (γ : Θ s r), A s (γ ∘ β))
    (xε : Aε.(fst) r β x),
      Typeᴿ r (fun s γ => B s (γ ∘ β) (fun t δ => x t (δ ∘ γ)) (Aε.(snd) _ _ x xε _ _)))
  : Type.
Proof.
refine (
  forall
    (x : (forall r (β : Θ r q), A r β))
    (xε : Aε.(fst) q (refl q) x),
    B _ (refl _) x xε
).
Defined.

Definition Prodᴿ p
  (q : Ω) (α : Θ q p)
  (A : Typeᵒ q)
  (Aε : Typeᴿ q A)
  (B : forall (r : Ω) (β : Θ r q)
    (x : forall (s : Ω) (γ : Θ s r), A s (γ ∘ β))
    (xε : Aε.(fst) r _ x), Type)
  (Bε : forall (r : Ω) (β : Θ r q)
    (x : forall (s : Ω) (γ : Θ s r), A s (γ ∘ β))
    (xε : Aε.(fst) r β x),
      Typeᴿ r (fun s γ => B s (γ ∘ β) (fun t δ => x t (δ ∘ γ)) (Aε.(snd) _ _ x xε _ _)))
  :
  Typeᴿ q (fun r γ =>
      Prodᵒ q r γ
        (fun s δ => A s (δ ∘ γ))
        (Typeᶱ _ _ Aε _ _)
        (fun s δ x xε => B s (δ ∘ γ) x xε)
        (fun s δ x xε => Bε _ _ x xε)
    ).
Proof.
unshelve refine (exist _ _ _ _).
+ unshelve refine (
  fun r γ f =>
    forall
      (x : (forall s δ, A s (δ ∘ γ)))
      (xε : Aε.(fst) _ _ x),
      (Bε _ _ x xε).(fst) r (refl r)
        (fun s δ => f s _
          (fun t ε => x t (ε ∘ δ))
          (Aε.(snd) _ _ x xε _ _)
        )
).
+ unshelve refine (
    fun r γ f fε s δ x xε => _
  ).
cbn in *.
Abort.

*)

Inductive unitᵒ (p : Ω) := ttᵒ.
Inductive unitε (p : Ω) : (forall q (α : Θ q p), unitᵒ q) -> Type :=
| ttε : unitε p (fun q _ => ttᵒ q).

Definition unitᴿ p : Typeᴿ p (fun q α => unitᵒ q).
Proof.
unshelve refine (exist _ _ _ _).
+ refine (fun q α => unitε q).
+ unshelve refine (fun q α i iε r β => _).
  destruct iε; constructor.
Defined.

Definition unit_indᵒ
  (p : Ω)
  (q : Ω) (α : Θ q p)
  (P : forall r (β : Θ r q)
    (i : forall s (γ : Θ s r), unitᵒ s)
    (iε : (unitᴿ r).(fst) r (refl r) i),
    Type)
  (Pε : forall
    (i : forall r (β : Θ r q), unitᵒ r)
    (iε : (unitᴿ q).(fst) q (refl _) i),
    Typeᴿ q (fun r β =>
      P r β
        (fun s γ => i s (γ ∘ β))
        ((unitᴿ q).(snd) _ (refl q) i iε _ β)
    )
  )
  (π : forall r (β : Θ r q), P r β (fun s γ => ttᵒ s) (ttε r))
  (πε : (Pε (fun r β => ttᵒ r) (ttε q)).(fst) q (refl q) π)
  (i : forall r (β : Θ r q), unitᵒ r)
  (iε : (unitᴿ q).(fst) q (refl q) i) :
  P q (refl q) i iε.
Proof.
refine (
  match iε in unitε _ i return P q (refl q) i iε with
  | ttε _ => π _ _
  end
).
Defined.

(* Definition unit_indᴿ *)
Goal Type.
unshelve refine (forall
  (p : Ω)
  (q : Ω) (α : Θ q p)
  (P : forall r (β : Θ r q)
    (i : forall s (γ : Θ s r), unitᵒ s)
    (iε : (unitᴿ r).(fst) r (refl r) i),
    Type)
  (Pε : forall
    (i : forall r (β : Θ r q), unitᵒ r)
    (iε : (unitᴿ q).(fst) q (refl _) i),
    Typeᴿ q (fun r β =>
      P r β
        (fun s γ => i s (γ ∘ β))
        ((unitᴿ q).(snd) _ (refl q) i iε _ β)
    )
  )
  (π : forall r (β : Θ r q), P r β (fun s γ => ttᵒ s) (ttε r))
  (πε : (Pε (fun r β => ttᵒ r) (ttε q)).(fst) q (refl q) π)
  (i : forall r (β : Θ r q), unitᵒ r)
  (iε : (unitᴿ q).(fst) q (refl q) i)
  ,
  (Pε i iε).(fst) q (refl q)
    (fun r β =>
      unit_indᵒ q r β
        (fun s γ i iε => P s (γ ∘ β) i iε)
        (fun i iε => _)
        (fun s γ => π s (γ ∘ β))
        _
        (fun s γ => i s (γ ∘ β))
        ((unitᴿ q).(snd) q (refl q) i iε r β)
  )).

cbn in *.
pose (unitᴿ r).(snd).
cbn in *.

refine (let X := Typeᶱ q (fun r β => P r β (fun s γ => i s (γ ∘ β)) _) in _).

pose (Typeᶱ r (fun s γ =>
  P s (γ ∘ β)
    (fun t δ => i t (δ ∘ γ))
    ((unitᴿ r).(snd) r (refl r) i iε _ _)
)).
cbn in *.
refine (Typeᶱ q (fun s γ => P s γ _ _) _ r β).
refine (Pε _ _).


Set Implicit Arguments.
Unset Strict Implicit.

Require Import QArith String Ascii ProofIrrelevance List Permutation.

Require Import Coq.FSets.FMapAVL Coq.FSets.FMapFacts.
Require Import Structures.Orders NArith.

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import all_ssreflect.
From mathcomp Require Import all_algebra.

Require Import strings compile orderedtypes dyadic numerics.
Require Import listlemmas maplemmas.

(** Dyadic-valued sparse vectors, implemented as balanced binary trees *)

Module Type PAYLOAD.
  Parameter t : Type. (* the low-level type *)
  Parameter t0 : t.   (* the "unit" value of type t *)
  Parameter eq0 : t -> bool.
  Parameter eq0P : forall x, reflect (x = t0) (eq0 x).
End PAYLOAD.

Class Rep t :=
  mkRep { u : Type;
          u_of_t : t -> u;
          t_of_u : u -> t;
          t_of_u_t : forall t, t_of_u (u_of_t t) = t }.

Module Type VECTOR.
  Declare Module B : BOUND.
  Declare Module P : PAYLOAD.

  Module Ix := MyOrdNatDepProps B.

  Parameter t : Type.

  Parameter get : Ix.t -> t -> P.t.
  Parameter set : Ix.t -> P.t -> t -> t.
  Parameter map0 : (Ix.t -> P.t -> P.t) -> t -> t.
  Parameter fold0 : forall T, (Ix.t -> P.t -> T -> T) -> t -> T -> T.
  Parameter foldr : forall T, (Ix.t -> P.t -> T -> T) -> t -> T -> T.
  Parameter any : (Ix.t -> P.t -> bool) -> t -> option (Ix.t * P.t).
  Parameter of_fun : (Ix.t -> P.t) -> t.
  Parameter mk_sparse : t -> t.
  Parameter argmax : (P.t -> P.t -> bool) -> t -> Ix.t.

  Parameter sparse : t -> Prop.
  Parameter mk_sparse_sparse : forall m, sparse (mk_sparse m).
  Parameter set_sparse : forall m i x, sparse m -> sparse (set i x m).
  Parameter map0_sparse : forall m f,
    (forall i x, f i x = P.t0 -> x = P.t0) ->
    sparse m ->
    sparse (map0 f m).

  Section REFINEMENT_PROOFS.
  Context `{rep : Rep P.t}.
  Definition ty := 'I_B.n -> u.
  Definition upd i p (f : ty) : ty := fun i' => if i == i' then p else f i'.

  Parameter Ix_of_Ordinal : 'I_B.n -> Ix.t.
  Parameter Ordinal_of_Ix : Ix.t -> 'I_B.n.
  Parameter Ix_of_Ordinal_Ix : forall i, Ix_of_Ordinal (Ordinal_of_Ix i) = i.
  Parameter Ordinal_of_Ix_Ordinal : forall i, Ordinal_of_Ix (Ix_of_Ordinal i) = i.

  (* the representation invariant *)
  Parameter match_vecs : t -> ty -> Prop.

  Section refinement_proofs.
    Variables (v : t) (f : ty).

    Parameter match_vecs_get :
      match_vecs v f ->
      forall i, get i v = t_of_u (f (Ordinal_of_Ix i)).
    Parameter match_vecs_set :
      match_vecs v f ->
      forall i p, match_vecs (set i p v) (upd (Ordinal_of_Ix i) (u_of_t p) f).
    Parameter match_vecs_map0 :
      match_vecs v f ->
      forall
        (g : Ix.t -> P.t -> P.t)
        (pf_g : forall i, g i P.t0 = P.t0),
      let g' := fun i u => u_of_t (g (Ix_of_Ordinal i) (t_of_u u)) in
      match_vecs (map0 g v) (fun i : 'I_B.n => g' i (f i)).
    Parameter match_vecs_foldr :
      match_vecs v f ->
      forall
        T (tx : T) (g : Ix.t -> P.t -> T -> T)
        (pf_g : forall i t, g i P.t0 t = t),
      let g' := fun i t => g (Ix_of_Ordinal i) (t_of_u (f i)) t in
      foldr g v tx =
      List.fold_right g' tx [seq (Ordinal_of_Ix ix) | ix <- enumerate Ix.t].

    (* foldr and fold0 are equivalent assuming the composition operator is
       symmetric, associative, and preserves zeros *)
    Parameter fold0_foldr :
      forall
        (Hsparse : sparse v)
        (g : P.t -> P.t -> P.t)
        (pf_g : forall t, g P.t0 t = t)
        (gcom : forall t1 t2, g t1 t2 = g t2 t1)
        (gassoc : forall t1 t2 t3, g t1 (g t2 t3) = g (g t1 t2) t3),
        fold0 (fun _ => g) v P.t0 = foldr (fun _ => g) v P.t0.
    Parameter match_vecs_fold0 :
      match_vecs v f ->
      forall
        (Hsparse : sparse v)
        (g : P.t -> P.t -> P.t)
        (pf_g : forall t, g P.t0 t = t)
        (gcom : forall t1 t2, g t1 t2 = g t2 t1)
        (gassoc : forall t1 t2 t3, g t1 (g t2 t3) = g (g t1 t2) t3),
      let g' := fun i t => g (t_of_u (f i)) t in
      fold0 (fun _ => g) v P.t0 =
      List.fold_right g' P.t0 (enum 'I_B.n).

    (* a single refinement lem for any would be better here... *)
    Parameter match_vecs_any_some :
      match_vecs v f ->
      forall g ix p,
        any g v = Some (ix, p) ->
        [/\ g ix p & t_of_u (f (Ordinal_of_Ix ix)) = p].
    Parameter match_vecs_any_none :
      match_vecs v f ->
      forall g,
        any g v = None ->
       forall i, g (Ix_of_Ordinal i) (t_of_u (f i)) = false.
    Parameter match_vecs_of_fun :
      forall g : Ix.t -> P.t,
        let: g' := fun i : 'I_B.n => u_of_t (g (Ix_of_Ordinal i)) in
        match_vecs (of_fun g) g'.

    Parameter match_vecs_mk_sparse :
      match_vecs (mk_sparse v) (fun i => u_of_t (get (Ix_of_Ordinal i) v)).
  End refinement_proofs.
  End REFINEMENT_PROOFS.
End VECTOR.

Module Vector (B : BOUND) (P : PAYLOAD) <: VECTOR.
  Module B := B.
  Module P := P.
  Module Ix := MyOrdNatDepProps B. (* the indices *)
  Module M := Make Ix.             (* sparse maps *)
  Module MFacts := Facts M.
  Module MProps := Properties M.
  Notation n := B.n.          (* the dimensionality *)
  Definition t := (M.t P.t).  (* the type of computable vectors *)

  (** [SPARSITY INVARIANT]:
      ~~~~~~~~~~~~~~~~~~~~~
      The map contains no key-value pairs (i,p) s.t. p = P.t0. That is,
      it only implicitly represents keys that map to the zero of the
      payload domain.
    *)

  Definition nonzero (p : P.t) : bool := negb (P.eq0 p).

  Definition sparse (m : t) := forall i y, M.find i m = Some y -> nonzero y.

  (* operations *)
  Definition get (i : Ix.t) (m : t) : P.t :=
    match M.find i m with
    | None => P.t0
    | Some p => p
    end.

  (* update i -> p; maintains [SPARSITY_INVARIANT] *)
  Definition set (i : Ix.t) (p : P.t) (m : t) : t :=
    if P.eq0 p then M.remove i m
    else M.add i p m.

  (* assumes f i P.t0 = P.t0 *)
  Definition map0 (f : Ix.t -> P.t -> P.t) (m : t) : t :=
    M.mapi f m.

  (* assumes f i P.t0 t = t *)
  Definition fold0 T (f : Ix.t -> P.t -> T -> T) (m : t) (t0 : T) : T :=
    M.fold f m t0.

  (* a slow fold0 that doesn't assume f i P.t0 t = t *)
  Definition foldr T (f : Ix.t -> P.t -> T -> T) (m : t) (t0 : T) : T :=
    List.fold_right (fun ix acc => f ix (get ix m) acc) t0 (enumerate Ix.t).

  (* does any (i, p) pair satisfy f? if so, which one? *)
  Fixpoint any_rec (f : Ix.t -> P.t -> bool) (m : t) (l : list Ix.t) : option (Ix.t * P.t) :=
    match l with
    | nil => None
    | i :: l' =>
      let p := get i m in
      if f i p then Some (i, p)
      else any_rec f m l'
    end.

  Definition any (f : Ix.t -> P.t -> bool) (m : t) : option (Ix.t * P.t) :=
    match List.find (fun i => f i (get i m)) (enumerate Ix.t) with
    | None => None
    | Some ix => Some (ix, get ix m)
    end.

  (* construct a vector from list of ordered pairs l *)
  Definition of_list_INTERNAL (l : list (Ix.t * P.t)) : t :=
    MProps.of_list l.

  (* same as of_list_INTERNAL but filters out pairs (i,p)
     s.t. p = P.t0, thus maintaining the [SPARSITY_INVARIANT] *)
  Definition of_list (l : list (Ix.t * P.t)) : t :=
    of_list_INTERNAL (List.filter (fun p : (Ix.t*P.t) => nonzero p.2) l).

  Definition to_list (m : t) : list (Ix.t * P.t) :=
    M.elements m.

  (* This returns the elements in the ascending order by index. *)
  Definition to_dense_list (m : t) : list (Ix.t * P.t) :=
    map (fun i => (i, get i m)) (enumerate Ix.t).

  (* construct a vector from function f *)
  Definition of_fun (f : Ix.t -> P.t) : t :=
    of_list (List.map (fun ix => (ix, f ix)) (enumerate Ix.t)).

  (* a slow map that doesn't assume anything *)
  Definition maps (f : Ix.t -> P.t -> P.t) (m : t) : t :=
    of_fun (fun ix => f ix (get ix m)).

  (* Given a lt function, find the index of the maximum element. If
     two elements are equal, the smaller index is chosen. *)
  Definition argmax (lt : P.t -> P.t -> bool) (m : t) : Ix.t :=
    let (i, _) := M.fold (fun k v (acc : Ix.t * P.t) =>
                            let (i, max) := acc in
                            if lt max v then (k, v)
                            else (i, max))
                         m (Ix.t0, get Ix.t0 m) in i.

  (* SPARSITY PROOFS *)
  Definition mk_sparse (m : t) : t := of_fun (fun ix => get ix m).

  Lemma mk_sparse_sparse m : sparse (mk_sparse m).
  Proof.
    rewrite /mk_sparse /sparse /of_fun /of_list => i t.
    rewrite /of_list_INTERNAL /MProps.of_list.
    rewrite -MProps.F.find_mapsto_iff MProps.F.elements_mapsto_iff.
    elim: (enumerate Ix.t) => //=.
    { rewrite MProps.elements_empty; inversion 1. }
    move => a l /= IH.
    case H: (nonzero (get a m)) => //=.
    rewrite /MProps.uncurry /= => H2.
    move: H2; rewrite -MFacts.elements_mapsto_iff.
    rewrite MProps.F.add_mapsto_iff; case.
    { by case => H2 H3; rewrite H3 in H. }
    case => H2; rewrite MFacts.elements_mapsto_iff => H3.
    by apply: IH.
  Qed.

  Lemma set_sparse m i t : sparse m -> sparse (set i t m).
  Proof.
    rewrite /sparse => H j k; rewrite /set; case: (P.eq0P t).
    { move => H2.
      case: (M.E.eq_dec i j) => H3.
      { rewrite MProps.F.remove_eq_o => //. }
      rewrite MProps.F.remove_neq_o => //; apply: H. }
    move => H2; case: (M.E.eq_dec i j) => H3.
    { rewrite MProps.F.add_eq_o => //; inversion 1; subst.
      apply/negP => H4; apply: H2; case: (P.eq0P k) H4 => //. }
    by rewrite MProps.F.add_neq_o => //; apply: H.
  Qed.

  (* map0 is only sparse if (f t = P.t0 -> t = P.t0) *)
  Lemma map0_sparse m f :
    (forall i t, f i t = P.t0 -> t = P.t0) ->
    sparse m ->
    sparse (map0 f m).
  Proof.
    move => pf; rewrite /sparse /map0 => H i t; move: (H i t) => H' H2.
    rewrite MFacts.mapi_o /option_map in H2; last first.
    { move => x y e; rewrite /N.eq; case: x => x pfx; case: y => y pfy /= Hxy.
      by subst x; have ->: pfx = pfy by apply: proof_irrelevance. }
    move: H' H2.
    case: (M.find i m) => // a H' H2; inversion H2; subst; move {H2}.
    move: (pf i a); case: (P.eq0P (f i a)).
    { move => H3; move/(_ H3) => H4; subst a; elimtype False.
      by rewrite H3 /nonzero /= in H'; move: (H' erefl); case: (P.eq0P P.t0). }
    by move => H2 H3; apply/negP; move: H2; case: (P.eq0P (f i a)).
  Qed.

  Section REFINEMENT_PROOFS.
  Context `{rep : Rep P.t}.
  Definition ty := 'I_n -> u. (* high-level vectors *)

  Definition upd i p (f : ty) : ty :=
    fun i' => if i == i' then p else f i'.

  Lemma Ix_of_Ordinal_lem x :
    (x < n)%N ->
    (N.to_nat (N.of_nat x) < n)%N.
  Proof. by rewrite Nat2N.id. Qed.

  Definition Ix_of_Ordinal (i : 'I_n) : Ix.t :=
    match i with
    | Ordinal x pf => @Ix.mk (N.of_nat x) (Ix_of_Ordinal_lem pf)
    end.

  Definition Ordinal_of_Ix (i : Ix.t) : 'I_n :=
    @Ordinal n (N.to_nat i.(Ix.val)) (Ix.pf i).

  Lemma Ix_of_Ordinal_Ix i : Ix_of_Ordinal (Ordinal_of_Ix i) = i.
  Proof.
    case: i => v pf /=.
    move: (Ix_of_Ordinal_lem _) => pf1; move: pf => pf2.
    move: pf1 pf2; rewrite N2Nat.id => pf1 pf2.
    f_equal.
    apply: proof_irrelevance.
  Qed.

  Lemma Ordinal_of_Ix_Ordinal i : Ordinal_of_Ix (Ix_of_Ordinal i) = i.
  Proof.
    case: i => m pf /=; rewrite /Ordinal_of_Ix /=.
    move: (Ix_of_Ordinal_lem _) => pf1; move: pf => pf2; move: pf1 pf2.
    rewrite Nat2N.id => pf1 pf2.
    f_equal.
    apply: proof_irrelevance.
  Qed.

  Lemma rev_enumerate_enum :
    List.rev (List.map Ordinal_of_Ix (enumerate Ix.t)) =
    enum 'I_n.
  Proof. apply: Ix.rev_enumerate_enum. Qed.

  Lemma Perm_enumerate_enum :
    Permutation
      (List.map Ordinal_of_Ix (enumerate Ix.t))
      (enum 'I_n).
  Proof.
    apply: Permutation_trans.
    apply: Permutation_rev.
    rewrite rev_enumerate_enum.
    apply: Permutation_refl.
  Qed.

  (* the representation invariant *)
  Definition match_vecs (v : t) (f : ty) : Prop :=
    forall i : Ix.t, get i v = t_of_u (f (Ordinal_of_Ix i)).

  Section refinement_proofs.
    Variables (v : t) (f : ty) (pf : match_vecs v f).

    Lemma match_vecs_get i :
      get i v = t_of_u (f (Ordinal_of_Ix i)).
    Proof. by apply: pf. Qed.

    Lemma match_vecs_set i p :
      match_vecs (set i p v) (upd (Ordinal_of_Ix i) (u_of_t p) f).
    Proof.
      move => j; rewrite /upd /set /get.
      case Heq: (P.eq0 p). (*P.t0 = p*)
      { move: (P.eq0P _ Heq) => <-.
        case: (Ix.eq_dec i j) => [px|px].
        { move: px; rewrite -Ix.eqP => H; rewrite H MProps.F.remove_eq_o; last first.
        { apply: N.eq_refl. }
        by subst i; rewrite eq_refl t_of_u_t. }
        have ->: (Ordinal_of_Ix i == Ordinal_of_Ix j = false).
        { case E: (Ordinal_of_Ix i == Ordinal_of_Ix j) => //.
          move: (eqP E) => F; elimtype False; apply: px.
          clear - E; move: E; case: i => i pfi; case: j => j pfj.
          rewrite /Ordinal_of_Ix /=; move/eqP; case; rewrite /Ix.eq /=.
          apply: N2Nat.inj. }
        rewrite MProps.F.remove_neq_o; last first.
        { move => H; apply: px.
          by case: i H => x pfx /=; case: j => y pfy /=. }
        by move: (P.eq0P _ Heq) => ->; apply: pf. }
      case: (Ix.eq_dec i j) => [px|px]. (*P.t0 <> p*)
      { move: px; rewrite -Ix.eqP => H; rewrite H MProps.F.add_eq_o; last first.
        { apply: N.eq_refl. }
        by subst i; rewrite eq_refl t_of_u_t. }
      have ->: (Ordinal_of_Ix i == Ordinal_of_Ix j = false).
      { case E: (Ordinal_of_Ix i == Ordinal_of_Ix j) => //.
        move: (eqP E) => F; elimtype False; apply: px.
        clear - E; move: E; case: i => i pfi; case: j => j pfj.
        rewrite /Ordinal_of_Ix /=; move/eqP; case; rewrite /Ix.eq /=.
        apply: N2Nat.inj. }
      rewrite MProps.F.add_neq_o; last first.
      { move => H; apply: px.
        by case: i H => x pfx /=; case: j => y pfy /=. }
      apply: pf.
    Qed.

    Lemma match_vecs_map0
          (g : Ix.t -> P.t -> P.t)
          (pf_g : forall i, g i P.t0 = P.t0) :
      let g' := fun i u => u_of_t (g (Ix_of_Ordinal i) (t_of_u u)) in
      match_vecs (map0 g v) (fun i : 'I_n => g' i (f i)).
    Proof.
      rewrite /map0 => j; rewrite /get MProps.F.mapi_o.
      case E: (M.find _ _) => /= [d|].
      { move: (pf j) => <-; f_equal; f_equal; rewrite /get E t_of_u_t.
        have ->: j = {| Ix.val := N.of_nat (N.to_nat (Ix.val j));
                        Ix.pf := Ix_of_Ordinal_lem (x:=N.to_nat (Ix.val j)) (Ix.pf j)|}.
        { clear E; case: j => j pfj /=; move: (Ix_of_Ordinal_lem _).
          rewrite N2Nat.id => i; f_equal; apply: proof_irrelevance. }
        simpl; f_equal; move: (Ix_of_Ordinal_lem _); rewrite N2Nat.id => pfj.
        move: (Ix_of_Ordinal_lem _); move: pfj; rewrite N2Nat.id => x y.
        f_equal; apply: proof_irrelevance. }
      { move: (pf j); rewrite /get E => H; rewrite t_of_u_t -H pf_g //. }
      case => ? pf1; case => ? pf2 e /=; rewrite /N.eq => Heq; move: pf1 pf2.
      rewrite Heq => ??; f_equal; f_equal; apply: proof_irrelevance.
    Qed.

    Lemma match_vecs_foldr
          T (tx : T) (g : Ix.t -> P.t -> T -> T)
          (pf_g : forall i t, g i P.t0 t = t) :
      let g' := fun i t => g (Ix_of_Ordinal i) (t_of_u (f i)) t in
      foldr g v tx =
      List.fold_right g' tx [seq (Ordinal_of_Ix ix) | ix <- enumerate Ix.t].
    Proof.
      rewrite /foldr; move: (enumerate Ix.t) => l.
      elim: l tx => // a l IH /= tx; f_equal => //.
      case: a => av apf; move: (Ix_of_Ordinal_lem _); rewrite N2Nat.id => pfix /=.
      by f_equal; apply: proof_irrelevance.
    Qed.

    (* foldr and fold0 are equivalent assuming the composition operator is
       symmetric, associative, and preserves zeros *)

    Definition foldr_aux1 T (g : Ix.t -> P.t -> T -> T) (m : t) (t0 : T) : T :=
      List.fold_right
        (fun ix acc => g ix (get ix m) acc) t0
        (List.filter (fun i => nonzero (get i m)) (enumerate Ix.t)).

    Lemma foldr_foldr_aux1
          T (tx : T) (g : Ix.t -> P.t -> T -> T)
          (pf_g : forall i t, g i P.t0 t = t) :
      foldr g v tx = foldr_aux1 g v tx.
    Proof.
      rewrite /foldr /foldr_aux1; move: (enumerate Ix.t) => l.
      elim: l tx => // a l IH tx /=; case H: (nonzero (get a v)) => /=.
      { f_equal; apply: IH. }
      have H2: (get a v = P.t0).
      { move: H; rewrite /nonzero => H.
        have H2: ~~ ~~ (P.eq0 (get a v)) by rewrite H.
        by rewrite negb_involutive in H2; move: (P.eq0P _ H2). }
      rewrite H2 pf_g; apply: IH.
    Qed.

    Definition foldr_aux2 T (g : Ix.t -> P.t -> T -> T) (m : t) (t0 : T) : T :=
      List.fold_right
        (fun ix acc => g ix (get ix m) acc) t0
        (map fst (M.elements m)).

    Lemma foldr_permute
          (g : P.t -> P.t -> P.t)
          (gcom : forall t1 t2, g t1 t2 = g t2 t1)
          (gassoc : forall t1 t2 t3, g t1 (g t2 t3) = g (g t1 t2) t3)
          l1 l2 :
      Permutation l1 l2 ->
      List.fold_right g P.t0 l1 = List.fold_right g P.t0 l2.
    Proof.
      elim => //; first by move => x l l' H /= ->.
      { move => x y l /=; move: (fold_right _ _ _) => z.
        by rewrite [g _ (g _ _)]gcom -[g (g _ _) _]gassoc [g z _]gcom. }
      by move => l l' l'' H H2 H3 H4; rewrite H2 H4.
    Qed.

    Lemma foldr_permute2
          (g : P.t -> P.t -> P.t)
          (gcom : forall t1 t2, g t1 t2 = g t2 t1)
          (gassoc : forall t1 t2 t3, g t1 (g t2 t3) = g (g t1 t2) t3)
          l1 l2 :
      Permutation l1 l2 ->
      let g' := (fun ix : Ix.t => [eta g (get ix v)]) in
      List.fold_right g' P.t0 l1 = List.fold_right g' P.t0 l2.
    Proof.
      elim => //; first by move => x l l' H /= ->.
      { move => x y l /=; move: (fold_right _ _ _) => z.
        by rewrite [g (get _ _) (g _ _)]gcom -[g (g _ _) _]gassoc [g z _]gcom. }
      by move => l l' l'' H H2 H3 H4 g'; rewrite H2 H4.
    Qed.

    Lemma foldr_permute3
          (g : P.t -> P.t -> P.t)
          (gcom : forall t1 t2, g t1 t2 = g t2 t1)
          (gassoc : forall t1 t2 t3, g t1 (g t2 t3) = g (g t1 t2) t3)
          l1 l2 :
      Permutation l1 l2 ->
      let g' := fun i t => g (t_of_u (f i)) t in
      List.fold_right (fun i : ordinal_finType n => [eta g (t_of_u (f i))]) P.t0 l1 =
      List.fold_right g' P.t0 l2.
    Proof.
      elim => //; first by move => x l l' H /= ->.
      { move => x y l /=; move: (fold_right _ _ _) => z.
        by rewrite [g _ (g _ _)]gcom -[g (g _ _) _]gassoc [g z _]gcom. }
      by move => l l' l'' H H2 H3 H4 g'; rewrite H2 H4.
    Qed.

    Lemma In_elements_find_Some_get x :
      In x [seq i.1 | i <- M.elements (elt:=P.t) v] ->
      M.find x v = Some (get x v).
    Proof.
      rewrite -MProps.F.find_mapsto_iff => H.
      rewrite /get; apply: M.elements_2.
      rewrite MFacts.elements_o.
      elim: (M.elements _) H => // [][]k a l IH /=.
      rewrite /MFacts.eqb; case: (M.E.eq_dec x k) => //.
      { move => H _; constructor; constructor => //. }
      move => H; case.
      { by move => H2; subst x; elimtype False; apply: H. }
      move => H2; move: (IH H2).
      have H3: findA (fun y : Ix.t' => if M.E.eq_dec x y then true else false) l =
               findA (MFacts.eqb x) l.
      { clear IH H2; elim: l => // [][]q y l IH /=; rewrite IH.
        rewrite [MFacts.eqb x q]/MFacts.eqb /is_left.
        case: (M.E.eq_dec _ _) => //. }
      by rewrite -H3 => H4; apply: InA_cons_tl.
    Qed.

    Lemma In_elements_find_Some x :
      In x (M.elements (elt:=P.t) v) ->
      M.find x.1 v = Some x.2.
    Proof.
      rewrite -MProps.F.find_mapsto_iff => H.
      rewrite /get; apply: M.elements_2.
      elim: (M.elements _) H => // [][]k a l IH /=; case.
      { by move => ->; constructor. }
      by move => H; apply: InA_cons_tl; apply: IH.
    Qed.

    Lemma In_elements_nonzero :
      sparse v ->
      forall x,
      In x [seq i.1 | i <- M.elements (elt:=P.t) v] ->
      nonzero (get x v) = true.
    Proof.
      move => H x; rewrite /get; move/In_elements_find_Some_get.
      rewrite /nonzero; move: (H x).
      by case: (M.find _ _) => // a; move/(_ a erefl).
    Qed.

    Lemma filter_InA' A (l : list A) r g a
      : InA r a (List.filter g l) -> InA r a l.
    Proof.
      elim: l => // ax l IH /=; case H2: (g ax).
      { inversion 1; subst; first by constructor => //.
        by apply: InA_cons_tl; apply: IH. }
      by move => H3; apply: InA_cons_tl; apply: IH.
    Qed.

    Lemma filtered_out A (l : list A) (r : A -> A -> Prop) g a
          (H0 : forall a a' : A, r a a' -> g a = g a')
      : InA r a l -> ~InA r a (List.filter g l) -> ~g a.
    Proof.
      elim: l => // ax l IH /=; case H2: (g ax).
      { inversion 1; subst.
        { by move => Hx Hy; apply: Hx; constructor. }
        move => Hx; apply: IH => //.
        by move => Hy; apply: Hx; apply: InA_cons_tl. }
      move => Hx Hy Hz; inversion Hx; subst.
      { by rewrite (H0 _ _ H1) H2 in Hz. }
      by apply: IH.
    Qed.

    Lemma filter_NoDupA A (l : list A) r g
      : NoDupA r l -> NoDupA r (List.filter g l).
    Proof.
      elim: l => // a l IH; inversion 1; subst => /=; case Hg: (g a).
      { constructor => //.
        { move => H4; apply: H2; apply: filter_InA'; apply: H4. }
        by apply: IH. }
      by apply: IH.
    Qed.

    Lemma Perm_elems_enum :
      sparse v ->
      Permutation
        (List.filter (fun i : Ix.t => nonzero (get i v)) (enumerate Ix.t))
        [seq i.1 | i <- M.elements (elt:=P.t) v].
    Proof.
      move => Hsparse; apply: NoDup_Permutation.
      { assert (H:
          NoDupA (fun x : Ix.t => [eta eq x])
                 (List.filter (fun i : Ix.t => nonzero (get i v)) (enumerate Ix.t))).
        { by apply: filter_NoDupA; case: Ix.enum_ok => H _. }
        elim: (enumerate Ix.t) H => //=; first by move => _; constructor.
        move => a l IH; case: (nonzero (get a v)) => //; inversion 1; subst.
        constructor.
        { move => H4; apply: H2; clear - H4.
          elim: l H4 => // x l IH /=; case: (nonzero _) => //=; case.
          { by move => ->; constructor. }
            by move => H; apply: InA_cons_tl; apply: IH. }
          by apply: IH. }
      { move: (M.elements_3w v); elim: (M.elements _) => //=.
        { move => _; constructor. }
        move => []a b l IH; inversion 1; subst; constructor => /=.
        { clear - H1 => H2; apply: H1; elim: l H2 => // [] ax l IH /=; case.
          { by move => <-; constructor; case: ax. }
          by move => H; apply: InA_cons_tl; apply: IH. }
        by apply: IH. }
      move => x; rewrite filter_In; split.
      { case => H; rewrite /get/nonzero MProps.F.elements_o.
        elim: (M.elements _) => /=; first by case: (P.eq0P P.t0).
        case => a b l IH; rewrite /MProps.F.eqb /M.E.eq_dec.
        case H2: (Ix.eq_dec _ _) => [eqpf|eqpf] /=.
        { move => H3; left; clear - eqpf; move: eqpf.
          case: x => xv xpf; case: a => av apf /=; rewrite /Ix.eq /N.eq /= => H.
          subst xv; f_equal; apply: proof_irrelevance. }
        by move => H3; right; apply: IH. }
      move => H; split; first by case: Ix.enum_ok.
      by apply: In_elements_nonzero.
    Qed.

    Lemma foldr_aux1_aux2
          (Hsparse : sparse v)
          (g : P.t -> P.t -> P.t)
          (gcom : forall t1 t2, g t1 t2 = g t2 t1)
          (gassoc : forall t1 t2 t3, g t1 (g t2 t3) = g (g t1 t2) t3) :
      foldr_aux1 (fun _ => g) v P.t0 = foldr_aux2 (fun _ => g) v P.t0.
    Proof.
      rewrite /foldr_aux1/foldr_aux2.
      apply: foldr_permute2 => //.
      by apply: Perm_elems_enum.
    Qed.

    Definition foldr_aux3 T (g : Ix.t -> P.t -> T -> T) (m : t) (t0 : T) : T :=
      List.fold_right
        (fun p acc => g p.1 p.2 acc) t0
        [seq (i.1, get i.1 m) | i <- M.elements m].

    Lemma foldr_aux2_aux3
          (g : P.t -> P.t -> P.t) :
      foldr_aux2 (fun _ => g) v P.t0 = foldr_aux3 (fun _ => g) v P.t0.
    Proof.
      rewrite /foldr_aux2 /foldr_aux3.
      elim: (M.elements _) => // [][]a b l IH /=.
      by f_equal; apply: IH => x H2.
    Qed.

    Definition foldr_aux4 T (g : Ix.t -> P.t -> T -> T) (m : t) (t0 : T) : T :=
      List.fold_right
        (fun p acc => g p.1 p.2 acc) t0
        (M.elements m).

    Lemma foldr_aux3_aux4
          (g : P.t -> P.t -> P.t) :
      foldr_aux3 (fun _ => g) v P.t0 = foldr_aux4 (fun _ => g) v P.t0.
    Proof.
      rewrite /foldr_aux3 /foldr_aux4.
      move: (In_elements_find_Some).
      elim: (M.elements v) => // [][]a b l IH H /=; rewrite IH.
      { by rewrite /get (H (a,b)); last by constructor. }
      by move => x H2; apply: H; right.
    Qed.

    Definition foldr_aux5 T (g : Ix.t -> P.t -> T -> T) (m : t) (t0 : T) : T :=
      List.fold_right
        (fun p acc => g p.1 p.2 acc) t0
        (List.rev (M.elements m)).

    Lemma foldr_aux4_aux5
          (g : P.t -> P.t -> P.t)
          (gcom : forall t1 t2, g t1 t2 = g t2 t1)
          (gassoc : forall t1 t2 t3, g t1 (g t2 t3) = g (g t1 t2) t3) :
      foldr_aux4 (fun _ => g) v P.t0 = foldr_aux5 (fun _ => g) v P.t0.
    Proof.
      move: P.t0 => tx; rewrite /foldr_aux4/foldr_aux5.
      move: (M.elements _) => l; elim: l tx => // a l IH tx /=.
      rewrite fold_right_app /= -IH; clear - gcom gassoc.
      set (f := (fun _ => [eta g _])).
      elim: l tx => // ax l /=; rewrite /f /= => IH tx.
      rewrite -IH; set (y := fold_right _ _ _).
      by rewrite 2!gassoc [g a.2 _]gcom.
    Qed.

    Lemma fold0_foldr
          (Hsparse : sparse v)
          (g : P.t -> P.t -> P.t)
          (pf_g : forall t, g P.t0 t = t)
          (gcom : forall t1 t2, g t1 t2 = g t2 t1)
          (gassoc : forall t1 t2 t3, g t1 (g t2 t3) = g (g t1 t2) t3) :
      fold0 (fun _ => g) v P.t0 = foldr (fun _ => g) v P.t0.
    Proof.
      rewrite /fold0 M.fold_1 -fold_left_rev_right.
      move: (foldr_aux4_aux5 gcom gassoc); rewrite /foldr_aux5 => <-.
      rewrite -foldr_aux3_aux4 -foldr_aux2_aux3 -foldr_aux1_aux2 //.
      rewrite foldr_foldr_aux1 //.
    Qed.

    Lemma match_vecs_fold0'
          (Hsparse : sparse v)
          (g : P.t -> P.t -> P.t)
          (pf_g : forall t, g P.t0 t = t)
          (gcom : forall t1 t2, g t1 t2 = g t2 t1)
          (gassoc : forall t1 t2 t3, g t1 (g t2 t3) = g (g t1 t2) t3) :
      let g' := fun i t => g (t_of_u (f i)) t in
      fold0 (fun _ => g) v P.t0 =
      List.fold_right g' P.t0 [seq (Ordinal_of_Ix ix) | ix <- enumerate Ix.t].
    Proof. by rewrite fold0_foldr //; apply: match_vecs_foldr. Qed.

    Lemma match_vecs_fold0
          (Hsparse : sparse v)
          (g : P.t -> P.t -> P.t)
          (pf_g : forall t, g P.t0 t = t)
          (gcom : forall t1 t2, g t1 t2 = g t2 t1)
          (gassoc : forall t1 t2 t3, g t1 (g t2 t3) = g (g t1 t2) t3) :
      let g' := fun i t => g (t_of_u (f i)) t in
      fold0 (fun _ => g) v P.t0 =
      List.fold_right g' P.t0 (enum 'I_n).
    Proof.
      rewrite match_vecs_fold0' // => g'.
      have ->:
        [seq Ordinal_of_Ix ix | ix <- enumerate Ix.t] =
        List.map Ordinal_of_Ix (enumerate Ix.t).
      { elim: (enumerate Ix.t) => //. }
      apply: foldr_permute3 => //.
      apply: Perm_enumerate_enum.
    Qed.

    (* a single refinement lem for any would be better here... *)

    Lemma match_vecs_any_some g ix p :
      any g v = Some (ix, p) ->
      [/\ g ix p & t_of_u (f (Ordinal_of_Ix ix)) = p].
    Proof.
      rewrite /any; case H: (List.find _ _) => [ix'|//].
      case => H1 H2; split.
      { by case: (List.find_some _ _ H) => _; rewrite H2 H1. }
      by move: (pf ix); rewrite -H1 H2 => ->.
    Qed.

    Lemma match_vecs_any_none g :
      any g v = None ->
      forall i, g (Ix_of_Ordinal i) (t_of_u (f i)) = false.
    Proof.
      rewrite /any; case H: (List.find _ _) => [//|] _ i.
      have H2: In (Ix_of_Ordinal i) (enumerate Ix.t).
      { case: (Ix.enum_ok) => _; apply. }
      move: (List.find_none _ _ H (Ix_of_Ordinal i) H2) => <-; f_equal.
      by rewrite (pf (Ix_of_Ordinal i)) Ordinal_of_Ix_Ordinal.
    Qed.

    Lemma match_vecs_of_list_INTERNAL (l : list (Ix.t * P.t)) :
      NoDupA (M.eq_key (elt:=P.t)) l ->
      match_vecs
        (of_list_INTERNAL l)
        (fun i =>
         u_of_t
           (match findA (MProps.F.eqb (Ix_of_Ordinal i)) l with
            | None => P.t0
            | Some p => p
            end)).
    Proof.
      clear v f pf.
      elim: l; first by simpl => H ix; rewrite /get MProps.F.empty_o t_of_u_t.
      case => ix p l IH; inversion 1; clear H; subst => ix'.
      move: (IH H3 ix'); rewrite /get 2!t_of_u_t Ix_of_Ordinal_Ix; clear IH.
      simpl; rewrite /MProps.uncurry /=; case: (Ix.eq_dec ix ix') => [pfx|pfx].
      { move: pfx; rewrite -Ix.eqP => <-.
        rewrite MProps.F.add_eq_o => //.
        have ->: MProps.F.eqb ix ix = true.
        { rewrite /MProps.F.eqb /M.E.eq_dec; case: (Ix.eq_dec _ _) => //.
          by rewrite -Ix.eqP. }
        by []. }
      rewrite MProps.F.add_neq_o => //.
      have ->: MProps.F.eqb ix' ix = false.
      { rewrite /MProps.F.eqb /M.E.eq_dec; case: (Ix.eq_dec _ _) => //.
        by move => X; elimtype False; apply: pfx. }
      by [].
    Qed.

    Lemma of_list_of_list_INTERNAL (l : list (Ix.t * P.t)) i :
      NoDupA (M.eq_key (elt:=P.t)) l ->
      get i (of_list l) = get i (of_list_INTERNAL l).
    Proof.
      move => H; rewrite /get /of_list /of_list_INTERNAL.
      rewrite (MProps.of_list_1b _ H).
      have H': NoDupA (M.eq_key (elt:=P.t))
                      (List.filter (fun p : Ix.t * P.t => nonzero p.2) l).
      { apply filter_NoDupA => //. }
      rewrite (MProps.of_list_1b _ H').
      case H2: (findA _ _) => [x|].
      { move: H2; rewrite -findA_NoDupA => // H2.
        move: (filter_InA' H2).
        generalize (@findA_NoDupA _ P.t _ _ Ix.eq_dec _ i x H).
        by rewrite /MProps.F.eqb /M.E.eq_dec => -> ->. }
      case H3: (findA _ _) => [y|//].
      move: H3; rewrite -findA_NoDupA => //.
      set (r := (fun _ _ => _ /\ _)) => H3.
      have H4: ~InA r (i,y) (List.filter (fun p => nonzero p.2) l).
      { clear - H2; elim: l H2 => //=; first by move => _; inversion 1.
        move => [] a b l IH => /=.
        case H: (nonzero b) => //=.
        case H2: (MProps.F.eqb i a) => // H3 H4; apply: IH => //.
        inversion H4; subst => //.
        clear - H H2 H1; move: H1; rewrite /r/N.eq/=; case => H5 ->.
        clear - H2 H5; elimtype False.
        move: H2; rewrite /MProps.F.eqb /M.E.eq_dec.
        case H6: (Ix.eq_dec i a) => //. }
      move: H4; set (g := (fun p : Ix.t * P.t => nonzero p.2)) => H4.
      have H5: forall a a' : Ix.t * P.t, r a a' -> g a = g a'.
      { by case => a pa; case => b pb; rewrite /r/g/nonzero /= => [][] Hx <-. }
      move: (@filtered_out _ l r g (i,y) H5 H3 H4).
      by rewrite /g /= /nonzero; move/negP; rewrite negb_involutive; move/P.eq0P.
    Qed.

    Lemma match_vecs_of_list (l : list (Ix.t * P.t)) :
      NoDupA (M.eq_key (elt:=P.t)) l ->
      match_vecs
        (of_list l)
        (fun i =>
         u_of_t
           (match findA (MProps.F.eqb (Ix_of_Ordinal i)) l with
            | None => P.t0
            | Some p => p
            end)).
    Proof.
      move => H; rewrite /match_vecs => i; rewrite of_list_of_list_INTERNAL => //.
      by apply: match_vecs_of_list_INTERNAL.
    Qed.

    Lemma match_vecs_to_list :
      [/\ NoDupA (M.eq_key (elt:=P.t)) (to_list v)
        & forall p,
          InA (M.eq_key_elt (elt:=P.t)) p (to_list v) ->
          p.2 = t_of_u (f (Ordinal_of_Ix p.1))].
    Proof.
      split; first by apply: M.elements_3w.
      case => i x; rewrite /to_list /= => H.
      apply M.elements_2 in H; move: H; rewrite MProps.F.find_mapsto_iff => H.
      by move: (pf i); rewrite /get H.
    Qed.

    Lemma match_vecs_of_fun (g : Ix.t -> P.t) :
      let: g' := fun i : 'I_n => u_of_t (g (Ix_of_Ordinal i)) in
      match_vecs (of_fun g) g'.
    Proof.
      rewrite /of_fun; case: (Ix.enum_ok) => H Htot ix.
      have H2: (NoDupA (M.eq_key (elt:=P.t)) [seq (ix, g ix) | ix <- enumerate Ix.t]).
      { clear - H; move: H; move: (enumerate _) => l; elim: l => //=.
        move => a l IH; inversion 1; subst; constructor.
        { move => H4; apply: H2; clear - H4; elim: l H4 => //=.
          { inversion 1. }
          move => az l IH; inversion 1; subst.
          { constructor; rewrite /M.eq_key /M.Raw.Proofs.PX.eqk /= in H0.
            clear - H0; move: H0; case: a => v pf /=; case: az => v' pf' /=.
            rewrite /N.eq => H; subst v'; f_equal.
            apply: proof_irrelevance. }
          by apply: InA_cons_tl; apply: IH. }
        by apply: IH. }
      move: (match_vecs_of_list H2 ix) ->; rewrite 2!t_of_u_t.
      rewrite /MProps.F.eqb Ix_of_Ordinal_Ix.
      move: (Htot ix) => H3.
      have H5:
        InA (fun p p' : Ix.t * P.t => Ix.eq p.1 p'.1 /\ p.2 = p'.2)
            (ix, g ix)
            [seq (ix, g ix) | ix <- enumerate Ix.t].
      { clear - H3; move: H3.
        move: (enumerate Ix.t) => l.
        elim: l => // a l IH; inversion 1; subst.
        { constructor; split => //. }
        by apply: InA_cons_tl; apply: IH. }
      generalize (findA_NoDupA _ Ix.eq_dec ix (g ix) H2).
      rewrite /M.E.eq_dec; case: (findA _ _).
      { by move => a; case => H4 _; case: (H4 H5). }
      by case => H4 _; move: (H4 H5).
    Qed.

    Lemma maps_correct m g i : get i (maps g m) = g i (get i m).
    Proof.
      rewrite /maps; move: (match_vecs_of_fun (fun ix : Ix.t => g ix (get ix m))).
      by move/(_ i) ->; rewrite t_of_u_t Ix_of_Ordinal_Ix.
    Qed.

    Lemma match_vecs_mk_sparse :
      match_vecs (mk_sparse v) (fun i => u_of_t (get (Ix_of_Ordinal i) v)).
    Proof. apply: (match_vecs_of_fun (fun ix => get ix v)). Qed.
  End refinement_proofs.
End REFINEMENT_PROOFS.
End Vector.

(* one-dimensional D-vectors *)

Module DPayload <: PAYLOAD.
  Definition t := DRed.t.
  Definition t0 := 0%DRed.
  Definition eq0 (dx : t) :=
    if Deq_dec dx.(DRed.d) 0 then true else false.
  Lemma eq0P (dx : t) : reflect (dx=0%DRed) (eq0 dx).
  Proof.
    rewrite /eq0; case: (Deq_dec dx.(DRed.d) 0) => a; constructor.
    { case: dx a => /= d pf H; subst d; unfold DRed.t0.
      f_equal; apply: proof_irrelevance. }
    by inversion 1; case: dx H H0 a => d pf; case => H /= _; subst d.
  Qed.
End DPayload.

Module DPayloadRep.
  Import DPayload.
  Definition u := dyadic_rat.
  Definition u_of_t (dx : t) := D_to_dyadic_rat dx.(DRed.d).
  Definition t_of_u (r : dyadic_rat) : t :=
    DRed.mk (Dred (dyadic_rat_to_D r)) (Dred_idem _).
  Lemma t_of_u_t : forall t0 : t, t_of_u (u_of_t t0) = t0.
  Proof.
    unfold t_of_u, u_of_t.
    intros [tx pf]; simpl.
    generalize (projT2 (D_to_dyadic_rat tx)) as x; intro.
    generalize (projT2 x) as y.
    generalize (projT1 x) as d; intro.
    intros H.
    assert (H2: Dred (D_to_dyadic_rat tx) = tx).
    { pattern tx at 2.
      rewrite <-pf.
      apply Dred_complete.
      assert (H3: dyadic_rat_to_D (D_to_dyadic_rat tx) = tx).
      { unfold dyadic_rat_to_D, D_to_dyadic_rat.
        destruct tx; simpl in *;
        auto.
      }
      rewrite H3; apply Qeq_refl. }
    clear - H2.
    generalize (Dred_idem (D_to_dyadic_rat tx)).
    generalize pf.
    revert H2; clear pf; intros -> pf e.
    f_equal; apply proof_irrelevance.
  Qed.
  Instance DPayloadRep : Rep t := mkRep t_of_u_t.
End DPayloadRep.

Definition Dabs (d : DRed.t) : DRed.t :=
  (if Dlt_bool d D0 then -d else d)%DRed.

Module DVector (B : BOUND).
  Module Vec := Vector B DPayload. Import Vec.

  Definition sum1 (v : Vec.t) : DRed.t :=
    Vec.fold0 (fun ix d acc => (d + acc)%DRed) v 0%DRed.

  Lemma sum1_sum v f :
    sparse v ->
    match_vecs v f ->
    Qeq (D_to_Q (sum1 v))
        (rat_to_Q (\sum_(i : 'I_B.n) projT1 (f i))).
  Proof.
    move => Hsparse H; rewrite /sum1.
    rewrite (match_vecs_fold0 (f := f)) => //.
    { rewrite -filter_index_enum; elim: (index_enum _).
      { rewrite big_nil //. }
      move => a l; rewrite big_cons /= => IH.
      rewrite rat_to_Q_plus !Dred_correct Dadd_ok IH.
      have ->: Qeq (D_to_Q (Dred (dyadic_rat_to_D (f a)))) (rat_to_Q (projT1 (f a))).
      { by rewrite Dred_correct dyadic_rat_to_Q. }
      by []. }
    { by move => t; rewrite /DPayload.t0 DRed.add0l. }
    { move => t1 t2; apply: DRed.addC. }
    move => t1 t2 t3; apply: DRed.addA.
  Qed.

  Definition dot_product (v1 v2 : Vec.t) : DRed.t :=
    sum1 (Vec.map0 (fun ix d1 => (d1 * Vec.get ix v2)%DRed) v1).

  Definition linf_norm (v : Vec.t) : DRed.t :=
    fold0
      (fun _ d (acc : DRed.t) => if Dlt_bool acc (Dabs d) then Dabs d else acc)
      v
      0%DRed.
End DVector.

Module MatrixPayload (B : BOUND) (P : PAYLOAD) <: PAYLOAD.
  Module Vec := Vector B P.
  Definition t := Vec.t.
  Definition t0 : t := Vec.M.empty _.
  Definition eq0 (d : t) := Vec.M.is_empty d.
  Lemma eq0P d : reflect (d=t0) (eq0 d).
  Proof.
    rewrite /eq0 /Vec.M.is_empty /Vec.M.Raw.is_empty /t0.
    case: d => x y /=; move: y; case: x => y; constructor => //.
    case H: Vec.M.empty => [z w]; inversion H; subst.
    f_equal; apply: proof_irrelevance.
  Qed.
End MatrixPayload.

(* Added for compatibility with gstew5/cage/winnow.v *)
Module DConstraintMatrixPayload (B : BOUND) <: PAYLOAD.
  Module DVec := DVector B. Include DVec.
  Definition label := bool.
  Definition t : Type := (Vec.t * label).
  Definition t0 : t := (Vec.M.empty _, false).
  Definition eq0 (d : t) := Vec.M.is_empty (fst d) && negb (snd d).
  Lemma eq0P d : reflect (d=t0) (eq0 d).
  Proof.
    rewrite /eq0 /Vec.M.is_empty /Vec.M.Raw.is_empty /t0.
    case: d => d; case.
    { case: d => x y /=; move: y; case: x => y; constructor => //. }
    case: d => x y /=; move: y; case: x => y; constructor => //.
    case H: Vec.M.empty => [z w]; inversion H; subst.
    f_equal; f_equal; apply: proof_irrelevance.
  Qed.
  Definition u := {m : t & {f : Vec.ty & Vec.match_vecs (fst m) f}}.
  Program Definition u_of_t (m : t) : u :=
    existT _ m _.
  Next Obligation.
    set (f := [ffun i : 'I_B.n =>
              u_of_t (Vec.get (Vec.Ix_of_Ordinal i) m.1)] : Vec.ty).
    refine (existT _ f _).
    by move => i; rewrite /f ffunE Vec.Ix_of_Ordinal_Ix t_of_u_t.
  Qed.
  Definition t_of_u (f : u) : t := projT1 f.
  Lemma t_of_u_t : forall t0 : t, t_of_u (u_of_t t0) = t0.
  Proof. by []. Qed.
End DConstraintMatrixPayload.

Module DConstraintMatrix (NumFeatures : BOUND) (NumConstraints : BOUND).
  Module Constraint := DConstraintMatrixPayload NumFeatures. Include Constraint.
  Module CMatrix := Vector NumConstraints Constraint.
End DConstraintMatrix.