(**************************************************************************************************
* Preservation and Progress for System-F kernel with Subtyping, Union and Intersection types        *
* Based on original code by: Brian Aydemir & Arthur Charguéraud, March 2007, Coq v8.1
* Modifications by Bruno C. d. S. Oliveira, Shaobo Cui and Baber Rehman, January 2020, Coq v8.7.0   *
***************************************************************************************************)

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

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

(** Representation of pre-types *)

Inductive typ : Set :=
  | typ_top   : typ
  | typ_bvar  : nat -> typ
  | typ_fvar  : var -> typ
  | typ_arrow : typ -> typ -> typ
  | typ_all   : typ -> typ -> typ
  | typ_and   : typ -> typ -> typ
  | typ_or    : typ -> typ -> typ.

(** Representation of pre-terms *)

Inductive trm : Set :=
  | trm_bvar : nat -> trm
  | trm_fvar : var -> trm
  | trm_abs  : typ -> trm -> trm
  | trm_app  : trm -> trm -> trm
  | trm_tabs : typ -> trm -> trm
  | trm_tapp : trm -> typ -> trm.

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

Fixpoint open_tt_rec (K : nat) (U : typ) (T : typ) {struct T} : typ :=
  match T with
  | typ_top         => typ_top
  | typ_bvar J      => If K = J then U else (typ_bvar J)
  | typ_fvar X      => typ_fvar X
  | typ_arrow T1 T2 => typ_arrow (open_tt_rec K U T1) (open_tt_rec K U T2)
  | typ_all T1 T2   => typ_all (open_tt_rec K U T1) (open_tt_rec (S K) U T2)
  | typ_and T1 T2   => typ_and (open_tt_rec K U T1) (open_tt_rec K U T2)
  | typ_or T1 T2    => typ_or (open_tt_rec K U T1) (open_tt_rec K U T2)
  end.

Definition open_tt T U := open_tt_rec 0 U T.

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

Fixpoint open_te_rec (K : nat) (U : typ) (e : trm) {struct e} : trm :=
  match e with
  | trm_bvar i    => trm_bvar i
  | trm_fvar x    => trm_fvar x
  | trm_abs V e1  => trm_abs  (open_tt_rec K U V)  (open_te_rec K U e1)
  | trm_app e1 e2 => trm_app  (open_te_rec K U e1) (open_te_rec K U e2)
  | trm_tabs V e1 => trm_tabs (open_tt_rec K U V)  (open_te_rec (S K) U e1)
  | trm_tapp e1 V => trm_tapp (open_te_rec K U e1) (open_tt_rec K U V)
  end.

Definition open_te t U := open_te_rec 0 U t.

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

Fixpoint open_ee_rec (k : nat) (f : trm) (e : trm) {struct e} : trm :=
  match e with
  | trm_bvar i    => If k = i then f else (trm_bvar i)
  | trm_fvar x    => trm_fvar x
  | trm_abs V e1  => trm_abs V (open_ee_rec (S k) f e1)
  | trm_app e1 e2 => trm_app (open_ee_rec k f e1) (open_ee_rec k f e2)
  | trm_tabs V e1 => trm_tabs V (open_ee_rec k f e1)
  | trm_tapp e1 V => trm_tapp (open_ee_rec k f e1) V
  end.

Definition open_ee t u := open_ee_rec 0 u t.

(** Notation for opening up binders with type or term variables *)

Notation "T 'open_tt_var' X" := (open_tt T (typ_fvar X)) (at level 67).
Notation "t 'open_te_var' X" := (open_te t (typ_fvar X)) (at level 67).
Notation "t 'open_ee_var' x" := (open_ee t (trm_fvar x)) (at level 67).

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

Inductive type : typ -> Prop :=
  | type_top :
      type typ_top
  | type_var : forall X,
      type (typ_fvar X)
  | type_arrow : forall T1 T2,
      type T1 ->
      type T2 ->
      type (typ_arrow T1 T2)
  | type_all : forall L T1 T2,
      type T1 ->
      (forall X, X \notin L -> type (T2 open_tt_var X)) ->
      type (typ_all T1 T2)
  | type_and : forall T1 T2,
      type T1 ->
      type T2 ->
      type (typ_and T1 T2)
  | type_or : forall T1 T2,
      type T1 ->
      type T2 ->
      type (typ_or T1 T2).

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

Inductive term : trm -> Prop :=
  | term_var : forall x,
      term (trm_fvar x)
  | term_abs : forall L V e1,
      type V ->
      (forall x, x \notin L -> term (e1 open_ee_var x)) ->
      term (trm_abs V e1)
  | term_app : forall e1 e2,
      term e1 ->
      term e2 ->
      term (trm_app e1 e2)
  | term_tabs : forall L V e1,
      type V ->
      (forall X, X \notin L -> term (e1 open_te_var X)) ->
      term (trm_tabs V e1)
  | term_tapp : forall e1 V,
      term e1 ->
      type V ->
      term (trm_tapp e1 V).

(** Binding are either mapping type or term variables.
 [X ~<: T] is a subtyping asumption and [x ~: T] is
 a typing assumption *)

Inductive bind : Set :=
  | bind_sub : typ -> bind
  | bind_typ : typ -> bind.

Notation "X ~<: T" := (X ~ bind_sub T)
  (at level 23, left associativity) : env_scope.
Notation "x ~: T" := (x ~ bind_typ T)
  (at level 23, left associativity) : env_scope.

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

Definition env := LibEnv.env bind.

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

Inductive wft : env -> typ -> Prop :=
  | wft_top : forall E,
      wft E typ_top
  | wft_var : forall U E X,
      binds X (bind_sub U) E ->
      wft E (typ_fvar X)
  | wft_arrow : forall E T1 T2,
      wft E T1 ->
      wft E T2 ->
      wft E (typ_arrow T1 T2)
  | wft_all : forall L E T1 T2,
      wft E T1 ->
      (forall X, X \notin L ->
        wft (E & X ~<: T1) (T2 open_tt_var X)) ->
      wft E (typ_all T1 T2)
  | wft_and : forall E T1 T2,
      wft E T1 ->
      wft E T2 ->
      wft E (typ_and T1 T2)
  | wft_or : forall E T1 T2,
      wft E T1 ->
      wft E T2 ->
      wft E (typ_or T1 T2).

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

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

(** Subtyping relation *)

Inductive sub : env -> typ -> typ -> Prop :=
  | sub_top : forall E S,
      okt E ->
      wft E S ->
      sub E S typ_top
  | sub_refl_tvar : forall E X,
      okt E ->
      wft E (typ_fvar X) ->
      sub E (typ_fvar X) (typ_fvar X)
  | sub_trans_tvar : forall U E T X,
      binds X (bind_sub U) E ->
      sub E U T ->
      sub E (typ_fvar X) T
  | sub_arrow : forall E S1 S2 T1 T2,
      sub E T1 S1 ->
      sub E S2 T2 ->
      sub E (typ_arrow S1 S2) (typ_arrow T1 T2)
  | sub_all : forall L E T1 T2 T3,
      (forall X, X \notin L ->
          sub (E & X ~<: T1) (T2 open_tt_var X) (T3 open_tt_var X)) ->
      sub E (typ_all T1 T2) (typ_all T1 T3)
  | sub_and1  : forall E t t1 t2,
        sub E t t1 -> sub E t t2 -> sub E t (typ_and  t1 t2)
  | sub_and2  : forall E t t1 t2 ,
        sub E t1 t -> wft E t2 -> sub E (typ_and t1 t2) t
  | sub_and3  : forall E t t1 t2,
        sub E t2 t -> wft E t1 -> sub E (typ_and t1 t2) t
  | sub_or1   : forall E t t1 t2,
        sub E t t2 -> sub E t1 t2 -> sub E (typ_or t t1) t2
  | sub_or2   : forall E t t1 t2,
        sub E t t1 -> wft E t2 -> sub E t (typ_or t1 t2)
  | sub_or3   : forall E t t1 t2,
        sub E t t2 -> wft E t1 -> sub E t (typ_or t1 t2).

(** Typing relation *)

Inductive typing : env -> trm -> typ -> Prop :=
  | typing_var : forall E x T,
      okt E ->
      binds x (bind_typ T) E ->
      typing E (trm_fvar x) T
  | typing_abs : forall L E V e1 T1,
      (forall x, x \notin L ->
        typing (E & x ~: V) (e1 open_ee_var x) T1) ->
      typing E (trm_abs V e1) (typ_arrow V T1)
  | typing_app : forall T1 E e1 e2 T2,
      typing E e1 (typ_arrow T1 T2) ->
      typing E e2 T1 ->
      typing E (trm_app e1 e2) T2
  | typing_tabs : forall L E V e1 T1,
      (forall X, X \notin L ->
        typing (E & X ~<: V) (e1 open_te_var X) (T1 open_tt_var X)) ->
      typing E (trm_tabs V e1) (typ_all V T1)
  | typing_tapp : forall T1 E e1 T T2,
      typing E e1 (typ_all T1 T2) ->
      sub E T T1 ->
      typing E (trm_tapp e1 T) (open_tt T2 T)
  | typing_sub : forall S E e T,
      typing E e S ->
      sub E S T ->
      typing E e T.

(** Values *)

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

(** One-step reduction *)

Inductive red : trm -> trm -> Prop :=
  | red_app_1 : forall e1 e1' e2,
      term e2 ->
      red e1 e1' ->
      red (trm_app e1 e2) (trm_app e1' e2)
  | red_app_2 : forall e1 e2 e2',
      value e1 ->
      red e2 e2' ->
      red (trm_app e1 e2) (trm_app e1 e2')
  | red_tapp : forall e1 e1' V,
      type V ->
      red e1 e1' ->
      red (trm_tapp e1 V) (trm_tapp e1' V)
  | red_abs : forall V e1 v2,
      term (trm_abs V e1) ->
      value v2 ->
      red (trm_app (trm_abs V e1) v2) (open_ee e1 v2)
  | red_tabs : forall V1 e1 V2,
      term (trm_tabs V1 e1) ->
      type V2 ->
      red (trm_tapp (trm_tabs V1 e1) V2) (open_te e1 V2).

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

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

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

(***************************************************************************
* Preservation and Progress for System-F with Subtyping - Infrastructure   *
* Brian Aydemir & Arthur Charguéraud, March 2007, Coq v8.1                 *
***************************************************************************)

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

(** Computing free type variables in a type *)

Fixpoint fv_tt (T : typ) {struct T} : vars :=
  match T with
  | typ_top         => \{}
  | typ_bvar J      => \{}
  | typ_fvar X      => \{X}
  | typ_arrow T1 T2 => (fv_tt T1) \u (fv_tt T2)
  | typ_all T1 T2   => (fv_tt T1) \u (fv_tt T2)
  | typ_and T1 T2 => (fv_tt T1) \u (fv_tt T2)
  | typ_or T1 T2 => (fv_tt T1) \u (fv_tt T2)
  end.

(** Computing free type variables in a term *)

Fixpoint fv_te (e : trm) {struct e} : vars :=
  match e with
  | trm_bvar i    => \{}
  | trm_fvar x    => \{}
  | trm_abs V e1  => (fv_tt V) \u (fv_te e1)
  | trm_app e1 e2 => (fv_te e1) \u (fv_te e2)
  | trm_tabs V e1 => (fv_tt V) \u (fv_te e1)
  | trm_tapp e1 V => (fv_tt V) \u (fv_te e1)
  end.

(** Computing free term variables in a type *)

Fixpoint fv_ee (e : trm) {struct e} : vars :=
  match e with
  | trm_bvar i    => \{}
  | trm_fvar x    => \{x}
  | trm_abs V e1  => (fv_ee e1)
  | trm_app e1 e2 => (fv_ee e1) \u (fv_ee e2)
  | trm_tabs V e1 => (fv_ee e1)
  | trm_tapp e1 V => (fv_ee e1)
  end.

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

Fixpoint subst_tt (Z : var) (U : typ) (T : typ) {struct T} : typ :=
  match T with
  | typ_top         => typ_top
  | typ_bvar J      => typ_bvar J
  | typ_fvar X      => If X = Z then U else (typ_fvar X)
  | typ_arrow T1 T2 => typ_arrow (subst_tt Z U T1) (subst_tt Z U T2)
  | typ_all T1 T2   => typ_all (subst_tt Z U T1) (subst_tt Z U T2)
  | typ_and T1 T2 => typ_and (subst_tt Z U T1) (subst_tt Z U T2)
  | typ_or T1 T2 => typ_or (subst_tt Z U T1) (subst_tt Z U T2)
  end.

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

Fixpoint subst_te (Z : var) (U : typ) (e : trm) {struct e} : trm :=
  match e with
  | trm_bvar i    => trm_bvar i
  | trm_fvar x    => trm_fvar x
  | trm_abs V e1  => trm_abs  (subst_tt Z U V)  (subst_te Z U e1)
  | trm_app e1 e2 => trm_app  (subst_te Z U e1) (subst_te Z U e2)
  | trm_tabs V e1 => trm_tabs (subst_tt Z U V)  (subst_te Z U e1)
  | trm_tapp e1 V => trm_tapp (subst_te Z U e1) (subst_tt Z U V)
  end.

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

Fixpoint subst_ee (z : var) (u : trm) (e : trm) {struct e} : trm :=
  match e with
  | trm_bvar i    => trm_bvar i
  | trm_fvar x    => If x = z then u else (trm_fvar x)
  | trm_abs V e1  => trm_abs V (subst_ee z u e1)
  | trm_app e1 e2 => trm_app (subst_ee z u e1) (subst_ee z u e2)
  | trm_tabs V e1 => trm_tabs V (subst_ee z u e1)
  | trm_tapp e1 V => trm_tapp (subst_ee z u e1) V
  end.

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

Definition subst_tb (Z : var) (P : typ) (b : bind) : bind :=
  match b with
  | bind_sub T => bind_sub (subst_tt Z P T)
  | bind_typ T => bind_typ (subst_tt Z P T)
  end.

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

(** Constructors as hints. *)

Hint Constructors type term wft ok okt value red.

Hint Resolve
  sub_top sub_refl_tvar sub_arrow
  typing_var typing_app typing_tapp typing_sub.

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

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

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

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

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

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

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

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

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

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

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

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

(** Tactic to undo when Coq does too much simplification *)

Ltac unsimpl_map_bind :=
  match goal with |- context [ ?B (subst_tt ?Z ?P ?U) ] =>
    unsimpl ((subst_tb Z P) (B U)) end.

Tactic Notation "unsimpl_map_bind" "*" :=
  unsimpl_map_bind; autos*.

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

(* ********************************************************************** *)
(** ** Properties of type substitution in type *)

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

Lemma open_tt_rec_type_core : forall T j V U i, i <> j ->
  (open_tt_rec j V T) = open_tt_rec i U (open_tt_rec j V T) ->
  T = open_tt_rec i U T.
Proof.
  induction T; introv Neq H; simpl in *; inversion H; f_equal*.
  case_nat*. case_nat*.
Qed.

Lemma open_tt_rec_type : forall T U,
  type T -> forall k, T = open_tt_rec k U T.
Proof.
 induction 1; intros; simpl; f_equal*. unfolds open_tt.
  pick_fresh X. apply* (@open_tt_rec_type_core T2 0 (typ_fvar X)).
Qed.

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

Lemma subst_tt_fresh : forall Z U T,
  Z \notin fv_tt T -> subst_tt Z U T = T.
Proof.
  induction T; simpl; intros; f_equal*.
  case_var*.
Qed.

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

Lemma subst_tt_open_tt_rec : forall T1 T2 X P n, type P ->
  subst_tt X P (open_tt_rec n T2 T1) =
  open_tt_rec n (subst_tt X P T2) (subst_tt X P T1).
Proof.
  introv WP. generalize n.
  induction T1; intros k; simpls; f_equal*.
  case_nat*.
  case_var*. rewrite* <- open_tt_rec_type.
Qed.

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

Lemma subst_tt_open_tt : forall T1 T2 X P, type P ->
  subst_tt X P (open_tt T1 T2) =
  open_tt (subst_tt X P T1) (subst_tt X P T2).
Proof.
  unfold open_tt. autos* subst_tt_open_tt_rec.
Qed.

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

Lemma subst_tt_open_tt_var : forall X Y U T, Y <> X -> type U ->
  (subst_tt X U T) open_tt_var Y = subst_tt X U (T open_tt_var Y).
Proof.
  introv Neq Wu. rewrite* subst_tt_open_tt.
  simpl. case_var*.
Qed.

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

Lemma subst_tt_intro : forall X T2 U,
  X \notin fv_tt T2 -> type U ->
  open_tt T2 U = subst_tt X U (T2 open_tt_var X).
Proof.
  introv Fr Wu. rewrite* subst_tt_open_tt.
  rewrite* subst_tt_fresh. simpl. case_var*.
Qed.

(* ********************************************************************** *)
(** ** Properties of type substitution in terms *)

Lemma open_te_rec_term_core : forall e j u i P ,
  open_ee_rec j u e = open_te_rec i P (open_ee_rec j u e) ->
  e = open_te_rec i P e.
Proof.
  induction e; intros; simpl in *; inversion H; f_equal*; f_equal*.
Qed.

Lemma open_te_rec_type_core : forall e j Q i P, i <> j ->
  open_te_rec j Q e = open_te_rec i P (open_te_rec j Q e) ->
   e = open_te_rec i P e.
Proof.
  induction e; intros; simpl in *; inversion H0; f_equal*;
  match goal with H: ?i <> ?j |- ?t = open_tt_rec ?i _ ?t =>
   apply* (@open_tt_rec_type_core t j) end.
Qed.

Lemma open_te_rec_term : forall e U,
  term e -> forall k, e = open_te_rec k U e.
Proof.
  intros e U WF. induction WF; intros; simpl;
    f_equal*; try solve [ apply* open_tt_rec_type ].
  unfolds open_ee. pick_fresh x.
   apply* (@open_te_rec_term_core e1 0 (trm_fvar x)).
  unfolds open_te. pick_fresh X.
   apply* (@open_te_rec_type_core e1 0 (typ_fvar X)).
Qed.

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

Lemma subst_te_fresh : forall X U e,
  X \notin fv_te e -> subst_te X U e = e.
Proof.
  induction e; simpl; intros; f_equal*; autos* subst_tt_fresh.
Qed.

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

Lemma subst_te_open_te : forall e T X U, type U ->
  subst_te X U (open_te e T) =
  open_te (subst_te X U e) (subst_tt X U T).
Proof.
  intros. unfold open_te. generalize 0.
  induction e; intros; simpls; f_equal*;
  autos* subst_tt_open_tt_rec.
Qed.

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

Lemma subst_te_open_te_var : forall X Y U e, Y <> X -> type U ->
  (subst_te X U e) open_te_var Y = subst_te X U (e open_te_var Y).
Proof.
  introv Neq Wu. rewrite* subst_te_open_te.
  simpl. case_var*.
Qed.

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

Lemma subst_te_intro : forall X U e,
  X \notin fv_te e -> type U ->
  open_te e U = subst_te X U (e open_te_var X).
Proof.
  introv Fr Wu. rewrite* subst_te_open_te.
  rewrite* subst_te_fresh. simpl. case_var*.
Qed.

(* ********************************************************************** *)
(** ** Properties of term substitution in terms *)

Lemma open_ee_rec_term_core : forall e j v u i, i <> j ->
  open_ee_rec j v e = open_ee_rec i u (open_ee_rec j v e) ->
  e = open_ee_rec i u e.
Proof.
  induction e; introv Neq H; simpl in *; inversion H; f_equal*.
  case_nat*. case_nat*.
Qed.

Lemma open_ee_rec_type_core : forall e j V u i,
  open_te_rec j V e = open_ee_rec i u (open_te_rec j V e) ->
  e = open_ee_rec i u e.
Proof.
  induction e; introv H; simpls; inversion H; f_equal*.
Qed.

Lemma open_ee_rec_term : forall u e,
  term e -> forall k, e = open_ee_rec k u e.
Proof.
  induction 1; intros; simpl; f_equal*.
  unfolds open_ee. pick_fresh x.
   apply* (@open_ee_rec_term_core e1 0 (trm_fvar x)).
   unfolds open_te. pick_fresh X.
   apply* (@open_ee_rec_type_core e1 0 (typ_fvar X)).
Qed.

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

Lemma subst_ee_fresh : forall x u e,
  x \notin fv_ee e -> subst_ee x u e = e.
Proof.
  induction e; simpl; intros; f_equal*.
  case_var*.
Qed.

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

Lemma subst_ee_open_ee : forall t1 t2 u x, term u ->
  subst_ee x u (open_ee t1 t2) =
  open_ee (subst_ee x u t1) (subst_ee x u t2).
Proof.
  intros. unfold open_ee. generalize 0.
  induction t1; intros; simpls; f_equal*.
  case_nat*.
  case_var*. rewrite* <- open_ee_rec_term.
Qed.

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

Lemma subst_ee_open_ee_var : forall x y u e, y <> x -> term u ->
  (subst_ee x u e) open_ee_var y = subst_ee x u (e open_ee_var y).
Proof.
  introv Neq Wu. rewrite* subst_ee_open_ee.
  simpl. case_var*.
Qed.

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

Lemma subst_ee_intro : forall x u e,
  x \notin fv_ee e -> term u ->
  open_ee e u = subst_ee x u (e open_ee_var x).
Proof.
  introv Fr Wu. rewrite* subst_ee_open_ee.
  rewrite* subst_ee_fresh. simpl. case_var*.
Qed.

(** Interactions between type substitutions in terms and opening
  with term variables in terms. *)

Lemma subst_te_open_ee_var : forall Z P x e,
  (subst_te Z P e) open_ee_var x = subst_te Z P (e open_ee_var x).
Proof.
  introv. unfold open_ee. generalize 0.
  induction e; intros; simpl; f_equal*. case_nat*.
Qed.

(** Interactions between term substitutions in terms and opening
  with type variables in terms. *)

Lemma subst_ee_open_te_var : forall z u e X, term u ->
  (subst_ee z u e) open_te_var X = subst_ee z u (e open_te_var X).
Proof.
  introv. unfold open_te. generalize 0.
  induction e; intros; simpl; f_equal*.
  case_var*. symmetry. autos* open_te_rec_term.
Qed.

(** Substitutions preserve local closure. *)

Lemma subst_tt_type : forall T Z P,
  type T -> type P -> type (subst_tt Z P T).
Proof.
  induction 1; intros; simpl; auto.
  case_var*.
  apply_fresh* type_all as X. rewrite* subst_tt_open_tt_var.
Qed.

Lemma subst_te_term : forall e Z P,
  term e -> type P -> term (subst_te Z P e).
Proof.
  lets: subst_tt_type. induction 1; intros; simpl; auto.
  apply_fresh* term_abs as x. rewrite* subst_te_open_ee_var.
  apply_fresh* term_tabs as x. rewrite* subst_te_open_te_var.
Qed.

Lemma subst_ee_term : forall e1 Z e2,
  term e1 -> term e2 -> term (subst_ee Z e2 e1).
Proof.
  induction 1; intros; simpl; auto.
  case_var*.
  apply_fresh* term_abs as y. rewrite* subst_ee_open_ee_var.
  apply_fresh* term_tabs as Y. rewrite* subst_ee_open_te_var.
Qed.

Hint Resolve subst_tt_type subst_te_term subst_ee_term.

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

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

Lemma wft_type : forall E T,
  wft E T -> type T.
Proof.
  induction 1; eauto.
Qed.

(** Through weakening *)

Lemma wft_weaken : forall G T E F,
  wft (E & G) T ->
  ok (E & F & G) ->
  wft (E & F & G) T.
Proof.
  intros. gen_eq K: (E & G). gen E F G.
  induction H; intros; subst; eauto.
  (* case: var *)
  apply (@wft_var U). apply* binds_weaken.
  (* case: all *)
  apply_fresh* wft_all as Y. apply_ih_bind* H1.
Qed.

(** Through strengthening *)

Lemma wft_strengthen : forall E F x U T,
 wft (E & x ~: U & F) T -> wft (E & F) T.
Proof.
  intros. gen_eq G: (E & x ~: U & F). gen F.
  induction H; intros F EQ; subst; auto.
  apply* (@wft_var U0). binds_cases H; try discriminate; autos*.
  apply_fresh* wft_all as Y. apply_ih_bind* H1.
Qed.

(** Through type substitution *)

Lemma wft_subst_tb : forall F Q E Z P T,
  wft (E & Z ~<: Q & F) T ->
  wft E P ->
  ok (E & map (subst_tb Z P) F) ->
  wft (E & map (subst_tb Z P) F) (subst_tt Z P T).
Proof.
  introv WT WP. gen_eq G: (E & Z ~<: Q & F). gen F.
  induction WT; intros F EQ Ok; subst; simpl subst_tt; auto.
  case_var*.
    apply_empty* wft_weaken.
    binds_cases H.
      apply* wft_var.
      apply (@wft_var (subst_tt Z P U)). unsimpl_map_bind*.
  apply_fresh* wft_all as Y.
   unsimpl ((subst_tb Z P) (bind_sub T1)).
   lets: wft_type.
   rewrite* subst_tt_open_tt_var.
   apply_ih_map_bind* H0.
Qed.

(** Through type reduction *)

Lemma wft_open : forall E U T1 T2,
  ok E ->
  wft E (typ_all T1 T2) ->
  wft E U ->
  wft E (open_tt T2 U).
Proof.
  introv Ok WA WU. inversions WA. pick_fresh X.
  autos* wft_type. rewrite* (@subst_tt_intro X).
  lets K: (@wft_subst_tb empty).
  specializes_vars K. clean_empty K. apply* K.
Qed.

(** Through narrowing *)

Lemma wft_narrow : forall V F U T E X,
  wft (E & X ~<: V & F) T ->
  ok (E & X ~<: U & F) ->
  wft (E & X ~<: U & F) T.
Proof.
  intros. gen_eq K: (E & X ~<: V & F). gen E F.
  induction H; intros; subst; eauto.
  destruct (binds_middle_inv H) as [K|[K|K]]; try destructs K.
    applys wft_var. apply* binds_concat_right.
    subst. applys wft_var. apply~ binds_middle_eq.
    applys wft_var. apply~ binds_concat_left.
     apply* binds_concat_left.
  apply_fresh* wft_all as Y. apply_ih_bind* H1.
Qed.

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

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

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

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

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

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

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

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

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

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

(** Inversion lemma *)

Lemma okt_push_inv : forall E X B,
  okt (E & X ~ B) -> (exists T, B = bind_sub T) \/ exists T, B = bind_typ T.
Proof.
  introv O. inverts O.
    false* empty_push_inv.
    lets (?&?&?): (eq_push_inv H). subst*.
    lets (?&?&?): (eq_push_inv H). subst*.
Qed.

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

Lemma okt_push_sub_type : forall E X T,
  okt (E & X ~<: T) -> type T.
Proof. intros. applys wft_type. forwards*: okt_push_tvr_inv. Qed.

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

Lemma okt_push_typ_type : forall E X T,
  okt (E & X ~: T) -> type T.
Proof. intros. applys wft_type. forwards*: okt_push_typ_inv. Qed.

(** Automation *)

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

Hint Resolve wft_weaken_right.

Hint Immediate wft_from_env_has_sub wft_from_env_has_typ.
Hint Resolve wft_subst_tb.
Hint Resolve wft_from_okt_typ wft_from_okt_sub.

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

(** Through narrowing *)

Lemma okt_narrow : forall V E F U X,
  okt (E & X ~<: V & F) ->
  wft E U ->
  okt (E & X ~<: U & F).
Proof.
  introv O W. induction F using env_ind.
  rewrite concat_empty_r in *. lets*: (okt_push_tvr_inv O).
  rewrite concat_assoc in *.
   lets [(?&?)|(?&?)]: okt_push_inv O; subst.
     lets (?&?&?): (okt_push_tvr_inv O).
      applys~ okt_sub. applys* wft_narrow.
     lets (?&?&?): (okt_push_typ_inv O).
      applys~ okt_typ. applys* wft_narrow.
Qed.

(** Through strengthening *)

Lemma okt_strengthen : forall x T E F,
  okt (E & x ~: T & F) ->
  okt (E & F).
Proof.
 introv O. induction F using env_ind.
  rewrite concat_empty_r in *. lets*: (okt_push_typ_inv O).
  rewrite concat_assoc in *.
   lets: okt_push_inv O. destruct H; subst.
     destruct H. subst.
     lets (?&?): (okt_push_tvr_inv O).
      applys~ okt_sub. applys* wft_strengthen. destruct* H0.
    destruct H. subst. lets (?&?): (okt_push_typ_inv O).
    applys~ okt_typ. applys* wft_strengthen. destruct* H0.
Qed.

Lemma okt_strengthen_l : forall E F,
  okt (E&F) ->
  okt E.
Proof. introv OKC. induction F using env_ind.
  rewrite concat_empty_r in *. auto.
  rewrite concat_assoc in *.
   lets: okt_push_inv OKC. destruct H; try destruct H; subst.
     lets (?&?): (okt_push_tvr_inv OKC). apply IHF. apply H.
      lets (?&?): (okt_push_typ_inv OKC). apply* IHF.
Qed.

(** Through type substitution *)

Lemma okt_subst_tb : forall Q Z P E F,
  okt (E & Z ~<: Q & F) ->
  wft E P ->
  okt (E & map (subst_tb Z P) F).
Proof.
 introv O W. induction F using env_ind.
  rewrite map_empty. rewrite concat_empty_r in *.
   lets*: (okt_push_tvr_inv O).
  rewrite map_push. rewrite concat_assoc in *.
   lets : okt_push_inv O. destruct H; try destruct H; subst.
   lets (?&?): (okt_push_tvr_inv O).
      applys~ okt_sub. destruct* H0. autos*.
      lets (?&?&?): (okt_push_typ_inv O).
      applys~ okt_typ. apply* wft_subst_tb.
Qed.

(** Automation *)

Hint Resolve okt_narrow okt_subst_tb wft_weaken.
Hint Immediate okt_strengthen.

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

Lemma notin_fv_tt_open : forall Y X T,
  X \notin fv_tt (T open_tt_var Y) ->
  X \notin fv_tt T.
Proof.
 introv. unfold open_tt. generalize 0.
 induction T; simpl; intros k Fr; auto.
 specializes IHT1 k. specializes IHT2 k. auto.
 specializes IHT1 k. specializes IHT2 (S k). auto.
 specializes IHT1 k. specializes IHT2 k. auto.
 specializes IHT1 k. specializes IHT2 k. auto.
Qed.

Lemma notin_fv_wf : forall E X T,
  wft E T -> X # E -> X \notin fv_tt T.
Proof.
  induction 1; intros Fr; simpl.
  eauto.
  rewrite notin_singleton. intro. subst. applys binds_fresh_inv H Fr.
  notin_simpl; auto.
  notin_simpl; auto. pick_fresh Y. apply* (@notin_fv_tt_open Y).
  notin_simpl; auto.
  notin_simpl; auto.
Qed.

Lemma map_subst_tb_id : forall G Z P,
  okt G -> Z # G -> G = map (subst_tb Z P) G.
Proof.
  induction 1; intros Fr; autorewrite with rew_env_map; simpl.
  auto.
  rewrite* <- IHokt. rewrite* subst_tt_fresh. apply* notin_fv_wf.
  rewrite* <- IHokt. rewrite* subst_tt_fresh. apply* notin_fv_wf.
Qed.

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

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

Lemma sub_regular : forall E S T,
  sub E S T -> okt E /\ wft E S /\ wft E T.
Proof.
  induction 1. autos*. autos*. autos*. autos*. (* Coq bug here? *)
  split.
  pick_fresh X.
  assert (X \notin L). eauto. destruct (H0 X H1).
    apply okt_push_tvr_inv in H2. autos*.
  split; apply_fresh* wft_all as Y.
  pick_fresh X.
  assert (X \notin L). eauto. destruct (H0 X H1).
    apply okt_push_tvr_inv in H2. autos*.
    destruct~ (H0 Y); apply_empty* (@wft_narrow T1).
  pick_fresh X.
  assert (X \notin L). eauto. destruct (H0 X H1).
    apply okt_push_tvr_inv in H2. autos*.
    destruct~ (H0 Y); apply_empty* (@wft_narrow T1).
  autos*. autos*. autos*. autos*. autos*. autos*.
Qed.

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

Lemma typing_regular : forall E e T,
  typing E e T -> okt E /\ term e /\ wft E T.
Proof.
  induction 1; splits*.
   pick_fresh y. specializes H0 y. destructs~ H0.
    forwards*: okt_push_typ_inv.
   apply_fresh* term_abs as y.
     pick_fresh y. specializes H0 y. destructs~ H0.
      forwards*: okt_push_typ_inv. destruct H3.
      destruct H4. apply wft_type in H4. auto.
     specializes H0 y. destructs~ H0.
   pick_fresh y. specializes H0 y. destructs~ H0.
    apply* wft_arrow.
      forwards*: okt_push_typ_inv.
      apply_empty* wft_strengthen.
  destructs IHtyping1. inversion* H3.
   pick_fresh y. specializes H0 y. destructs~ H0.
    forwards*: okt_push_tvr_inv.
  apply term_tabs with (L:=L).
   pick_fresh X. destruct H0 with (X:=X).
  autos. apply okt_push_tvr_inv in H1. destruct H1. destruct H3.
  apply wft_type in H3. auto.
   intros.
      forwards~ K: (H0 X). destructs K.
       forwards*: okt_push_tvr_inv.
   apply_fresh* wft_all as Y.
     pick_fresh y. forwards~ K: (H0 y). destructs K.
      forwards*: okt_push_tvr_inv.
     forwards~ K: (H0 Y). destructs K.
      forwards*: okt_push_tvr_inv.
  apply term_tapp; autos*. eapply wft_type. apply sub_regular in H0.
  destruct* H0.
  destruct IHtyping. destruct H2. inversion H3.  subst.
   applys* wft_open T1. apply sub_regular in H0. destruct* H0.
   apply sub_regular in H0. destruct* H0.
Qed.

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

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

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

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

(** Automation *)

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

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

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

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

(***************************************************************************
* Preservation and Progress for System-F with Subtyping - Proofs           *
* Brian Aydemir & Arthur Charguéraud, March 2007, Coq v8.1                 *
***************************************************************************)

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

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

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

Lemma sub_reflexivity : forall E T,
  okt E ->
  wft E T ->
  sub E T T .
Proof.
  introv Ok WFT. lets W:(wft_type WFT). gen E.
  induction W; intros; inversions WFT; eauto.
  - apply_fresh* sub_all as Y.
  - apply sub_and1. apply sub_and2. eauto. eauto.
    apply sub_and3. eauto. eauto.
  - apply sub_or1. apply sub_or2. eauto. eauto.
    apply sub_or3. eauto. eauto.
Qed.

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

Lemma sub_weakening : forall E F G S T,
   sub (E & G) S T ->
   okt (E & F & G) ->
   sub (E & F & G) S T.
Proof.
  introv Typ. gen_eq H: (E & G). gen G.
  induction Typ; introv EQ Ok; subst; auto.
  (* case: fvar trans *)
  apply* sub_trans_tvar. apply* binds_weaken.
  (* case: all *)
  apply_fresh* sub_all as Y. apply_ih_bind* H0.
  pick_fresh X.
  assert (X \notin L). eauto.
  eapply sub_regular in H; eauto. autos*.
  (* Cases: Union and Intersection *)
  apply sub_and1; eauto.
  apply sub_and2; eauto.
  apply sub_and3; eauto.
  apply sub_or1; eauto.
  apply sub_or2; eauto.
  apply sub_or3; eauto.
Qed.

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

Section NarrowTrans.

Definition transitivity_on Q := forall E S T,
  sub E S Q -> sub E Q T -> sub E S T.

Hint Unfold transitivity_on.

Hint Resolve wft_narrow.

Require Import Program.Equality.

Lemma sub_narrowing_aux : forall Q F E Z P S T,
  transitivity_on Q ->
  sub (E & Z ~<: Q & F) S T ->
  sub E P Q ->
  sub (E & Z ~<: P & F) S T.
Proof.
  introv TransQ SsubT PsubQ.
  gen_eq G: (E & Z ~<: Q & F). gen F.
  induction SsubT; introv EQ; subst.
  apply* sub_top.
  apply* sub_refl_tvar.
  tests EQ: (X = Z); subst.
    apply (@sub_trans_tvar P); autos* (@okt_narrow Q).
    apply binds_concat_left_ok; eauto.
      apply TransQ.
        do_rew* concat_assoc (apply_empty* sub_weakening).
        binds_get H. autos*.
    apply* (@sub_trans_tvar U).
    binds_cases H; auto.
  apply* sub_arrow.
  apply_fresh* sub_all as Y. apply_ih_bind* H0.
  apply sub_and1. eauto. eauto.
  apply sub_and2. eauto. eauto.
  apply sub_and3. eauto. eauto.
  apply sub_or1. eauto. eauto.
  apply sub_or2. eauto. eauto.
  apply sub_or3. eauto. eauto.
Qed.

Lemma invAndS1 : forall E t t1 t2, sub E t (typ_and t1 t2) -> sub E t t1 /\ sub E t t2.
Proof.
  intros. dependent induction H.
  - destruct (IHsub _ _ eq_refl).
    split; econstructor; eauto.
  - auto.
  - destruct (IHsub _ _ eq_refl).
    split; apply sub_and2; eauto.
  - destruct (IHsub _ _ eq_refl).
    split; apply sub_and3; eauto.
  - destruct (IHsub1 _ _ eq_refl).
    destruct (IHsub2 _ _ eq_refl).
    split; constructor; auto.
Defined.

Lemma invOrS1 : forall E t t1 t2, sub E (typ_or t1 t2) t -> sub E t1 t /\ sub E t2 t.
Proof.
  intros. dependent induction H.
  - inversion H0. auto.
  - destruct (IHsub1 _ _ eq_refl);
    split; apply sub_and1; auto;
    destruct (IHsub2 _ _ eq_refl); auto.
  - split; auto.
  - destruct (IHsub _ _ eq_refl).
    split; constructor; auto.
  - destruct (IHsub _ _ eq_refl).
    split; apply sub_or3; auto.
Defined.

Hint Resolve invAndS1 invOrS1 sub_trans_tvar sub_and1
sub_and2 sub_and3 sub_or1 sub_or2 sub_or3.

Lemma sub_transitivity : forall Q,
  transitivity_on Q.
Proof.
  unfold transitivity_on.
  intros Q E S T SsubQ QsubT.
  assert (W : type Q) by auto.
  generalize dependent T.
  generalize dependent S.
  generalize dependent E.
  remember Q as Q' in |- *.
  generalize dependent Q'.
  induction W; intros.
  - dependent induction QsubT; try discriminate; eauto.
  - dependent induction SsubQ; try discriminate; eauto.
  - dependent induction QsubT; try discriminate; eauto.
    clear IHQsubT1. clear IHQsubT2.
    dependent induction SsubQ; eauto.
  - dependent induction SsubQ; try discriminate; eauto.
    dependent induction QsubT; eauto 4 using sub_trans_tvar.
      (*sub_all / sub_top*)
    assert (sub E (typ_all T1 T3) (typ_all T1 T2)).
      (*proof of assertion*)
      pick_fresh y; apply* sub_all.
    auto.
    (*sub_all / sub_all*)
  apply_fresh sub_all as X; autos*.
  lapply (H0 X); [ intros K | auto ].
  apply (K (T2 open_tt_var X)); auto.
  - subst. dependent induction QsubT. auto. eauto.
    clear IHQsubT.
    dependent induction SsubQ; eauto.
    apply invAndS1 in SsubQ. destruct SsubQ. eauto. eauto. eauto.
  - subst. dependent induction SsubQ.
    eauto. eauto. eauto. eauto.
     clear IHSsubQ.
     dependent induction QsubT; eauto.
    apply invOrS1 in QsubT. destruct QsubT. eauto.
Qed.

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

End NarrowTrans.

(* ********************************************************************** *)
(** Type substitution preserves subtyping (10) *)

Lemma sub_through_subst_tt : forall Q E F Z S T P,
  sub (E & Z ~<: Q & F) S T ->
  sub E P Q ->
  sub (E & map (subst_tb Z P) F) (subst_tt Z P S) (subst_tt Z P T).
Proof.
  introv SsubT PsubQ.
  gen_eq G: (E & Z ~<: Q & F). gen F.
  induction SsubT; introv EQ; subst; simpl subst_tt.
  apply* sub_top.
  case_var.
    apply* sub_reflexivity.
    apply* sub_reflexivity.
     inversions H0. binds_cases H3. (* wf *)
      apply* (@wft_var U).
      apply* (@wft_var (subst_tt Z P U)). unsimpl_map_bind*.
   case_var.
    apply (@sub_transitivity Q).
      apply_empty* sub_weakening.
      rewrite* <- (@subst_tt_fresh Z P Q).
        binds_get H. autos*.
        apply* (@notin_fv_wf E).
    apply* (@sub_trans_tvar (subst_tt Z P U)).
      rewrite* (@map_subst_tb_id E Z P).
        binds_cases H; unsimpl_map_bind*.
  apply* sub_arrow.
  apply_fresh* sub_all as X.
   unsimpl (subst_tb Z P (bind_sub T1)).
   do 2 rewrite* subst_tt_open_tt_var.
   apply_ih_map_bind* H0.
  apply* sub_and1.
  apply* sub_and2.
  apply* sub_and3.
  apply* sub_or1.
  apply* sub_or2.
  apply* sub_or3.
Qed.

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

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

Lemma typing_weakening : forall E F G e T,
   typing (E & G) e T ->
   okt (E & F & G) ->
   typing (E & F & G) e T.
Proof.
  introv Typ. gen_eq H: (E & G). gen G.
  induction Typ; introv EQ Ok; subst.
  apply* typing_var. apply* binds_weaken.
  apply_fresh* typing_abs as x. forwards~ K: (H x).
   apply_ih_bind (H0 x); eauto.
  apply* typing_app.
  apply_fresh* typing_tabs as X. forwards~ K: (H X).
   apply_ih_bind (H0 X); eauto.
  apply* typing_tapp. apply* sub_weakening.
  apply* typing_sub. apply* sub_weakening.
Qed.

(* ********************************************************************** *)
(** Strengthening (6) *)

Lemma sub_strengthening : forall x U E F S T,
  sub (E & x ~: U & F) S T ->
  sub (E & F) S T.
Proof.
  intros x U E F S T SsubT.
  gen_eq G: (E & x ~: U & F). gen F.
  induction SsubT; introv EQ; subst; autos* wft_strengthen.
  (* case: fvar trans *)
  apply* (@sub_trans_tvar U0). binds_cases H; autos*.
  (* case: all *)
  apply_fresh* sub_all as X. apply_ih_bind* H0.
  apply* sub_and1.
  apply* sub_and2.
  apply* sub_and3.
  apply* sub_or1.
  apply* sub_or2.
  apply* sub_or3.
Qed.

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

Lemma typing_narrowing : forall Q E F X P e T,
  sub E P Q ->
  typing (E & X ~<: Q & F) e T ->
  typing (E & X ~<: P & F) e T.
Proof.
  introv PsubQ Typ. gen_eq E': (E & X ~<: Q & F). gen F.
  induction Typ; introv EQ; subst.
  binds_cases H0; apply* typing_var.
  apply_fresh* typing_abs as y. apply_ih_bind* H0.
  apply* typing_app.
  apply_fresh* typing_tabs as Y. apply_ih_bind* H0.
  apply* typing_tapp. apply* (@sub_narrowing Q).
  apply* typing_sub. apply* (@sub_narrowing Q).
Qed.

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

Lemma typing_through_subst_ee : forall U E F x T e u,
  typing (E & x ~: U & F) e T ->
  typing E u U ->
  typing (E & F) (subst_ee x u e) T.
Proof.
  introv TypT TypU. gen_eq E': (E & x ~: U & F). gen F.
  induction TypT; introv EQ; subst; simpl.
  case_var.
    binds_get H0. apply_empty* typing_weakening.
    binds_cases H0; apply* typing_var.
  apply_fresh* typing_abs as y.
    rewrite* subst_ee_open_ee_var.
    apply_ih_bind* H0.
  apply* typing_app.
  apply_fresh* typing_tabs as Y.
    rewrite* subst_ee_open_te_var.
    apply_ih_bind* H0.
  apply* typing_tapp. apply* sub_strengthening.
  apply* typing_sub. apply* sub_strengthening.
Qed.

(************************************************************************ *)
(** Preservation by Type Substitution (11) *)

Lemma typing_through_subst_te : forall Q E F Z e T P,
  typing (E & Z ~<: Q & F) e T ->
  sub E P Q ->
  typing (E & map (subst_tb Z P) F) (subst_te Z P e) (subst_tt Z P T).
Proof.
  introv Typ PsubQ. gen_eq G: (E & Z ~<: Q & F). gen F.
  induction Typ; introv EQ; subst; simpls subst_tt; simpls subst_te.
  apply* typing_var. rewrite* (@map_subst_tb_id E Z P).
   binds_cases H0; unsimpl_map_bind*.
  apply_fresh* typing_abs as y.
    unsimpl (subst_tb Z P (bind_typ V)).
    rewrite* subst_te_open_ee_var.
    apply_ih_map_bind* H0.
  apply* typing_app.
  apply_fresh* typing_tabs as Y.
    unsimpl (subst_tb Z P (bind_sub V)).
    rewrite* subst_te_open_te_var.
    rewrite* subst_tt_open_tt_var.
    apply_ih_map_bind* H0.
  rewrite* subst_tt_open_tt. apply* typing_tapp.
    apply* sub_through_subst_tt.
  apply* typing_sub. apply* sub_through_subst_tt.
Qed.

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

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

Lemma typing_inv_abs : forall E S1 e1 T,
  typing E (trm_abs S1 e1) T ->
  forall U1 U2, sub E T (typ_arrow U1 U2) ->
     sub E U1 S1
  /\ exists S2, exists L, forall x, x \notin L ->
     typing (E & x ~: S1) (e1 open_ee_var x) S2 /\ sub E S2 U2.
Proof.
  introv Typ. gen_eq e: (trm_abs S1 e1). gen S1 e1.
  induction Typ; intros S1 b1 EQ U1 U2 Sub; inversions EQ.
  inversions* Sub. autos* (@sub_transitivity T).
Qed.

Lemma typing_inv_tabs : forall E S1 e1 T,
  typing E (trm_tabs S1 e1) T ->
  forall U1 U2, sub E T (typ_all U1 U2) ->
     sub E U1 S1
  /\ exists S2, exists L, forall X, X \notin L ->
     typing (E & X ~<: U1) (e1 open_te_var X) (S2 open_tt_var X)
     /\ sub (E & X ~<: U1) (S2 open_tt_var X) (U2 open_tt_var X).
Proof.
  intros E S1 e1 T H. gen_eq e: (trm_tabs S1 e1). gen S1 e1.
  induction H; intros S1 b EQ U1 U2 Sub; inversion EQ.
  inversions Sub. splits.
  apply sub_reflexivity.
  pick_fresh X.
  assert (X \notin L ). eauto.
  eapply typing_regular in H; eauto.
  destruct H. apply okt_strengthen_l in H. auto.
  pick_fresh X.
  assert (X \notin L). eauto.
  eapply typing_regular in H; eauto.
  destruct H. destruct H2. autos*.
   exists T1. let L1 := gather_vars in exists L1.
   intros Y Fr. splits.
    apply_empty* (@typing_narrowing U1).
  apply sub_reflexivity.
  pick_fresh X.
  assert (X \notin L ). eauto.
  eapply typing_regular in H; eauto.
  destruct H. apply okt_strengthen_l in H. auto.
  pick_fresh X.
  assert (X \notin L). eauto.
  eapply typing_regular in H; eauto.
  destruct H. destruct H2. autos*.
  auto. autos* (@sub_transitivity T).
Qed.

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

Lemma preservation_result : preservation.
Proof.
  introv Typ. gen e'. induction Typ; introv Red;
   try solve [ inversion Red ].
  (* case: app *)
  inversions Red; try solve [ apply* typing_app ].
  destruct~ (typing_inv_abs Typ1 (U1:=T1) (U2:=T2)) as [P1 [S2 [L P2]]].
    apply* sub_reflexivity.
    pick_fresh X. forwards~ K: (P2 X). destruct K.
     rewrite* (@subst_ee_intro X).
     apply_empty (@typing_through_subst_ee V).
       apply* (@typing_sub S2). apply_empty* sub_weakening.
       autos*.
  (* case: tapp *)
  inversions Red; try solve [ apply* typing_tapp ].
  destruct~ (typing_inv_tabs Typ (U1:=T1) (U2:=T2)) as [P1 [S2 [L P2]]].
    apply* sub_reflexivity.
    pick_fresh X. forwards~ K: (P2 X). destruct K.
     rewrite* (@subst_te_intro X).
     rewrite* (@subst_tt_intro X).
     replace E with (E & map (subst_tb X T) empty).
     apply* (@typing_through_subst_te T1).
    assert (typing (E & X ~<: T1) (e0 open_te_var X) (T2 open_tt_var X)).
   eapply typing_sub; eauto.
   replace (E & X ~<: T1 & empty) with (E & X ~<: T1); auto.
   symmetry. apply concat_empty_r.
   rewrite map_empty. apply concat_empty_r.
  (* case sub *)
  apply* typing_sub.
Qed.

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

(* ********************************************************************** *)
(** Canonical Forms (14) *)

Lemma canonical_form_abs : forall t U1 U2,
  value t -> typing empty t (typ_arrow U1 U2) ->
  exists V, exists e1, t = trm_abs V e1.
Proof.
  introv Val Typ.
  gen_eq T: (typ_arrow U1 U2). intro st.
   assert (sub empty T (typ_arrow U1 U2)).
{ rewrite st.
    apply sub_reflexivity with (E:=empty); auto. subst. apply typing_regular in Typ.
    destruct Typ. destruct H0. auto. }
  clear st. gen_eq E: (@empty typ).  gen U1 U2.
  induction Typ; introv EQT EQE;
   try solve [ inversion Val | inversion EQT | eauto ].
    subst. assert (sub E0 S (typ_arrow U1 U2)). {
    eapply sub_transitivity. apply H. apply EQT. }
   eapply IHTyp. apply Val. apply H0. reflexivity.
Qed.

Lemma tall_inv : forall E T1 T2 M N,
sub E (typ_all T1 M) (typ_all T2 N) -> T1=T2.
Proof. intros.
- inversion H. subst. autos*.
Qed.

Lemma canonical_form_tabs : forall t T U,
  value t -> typing empty t (typ_all T U) ->
  exists e1, t = trm_tabs T e1.
Proof.
  introv Val Typ.
  gen_eq Ty: (typ_all T U). intro st.
  assert (sub empty Ty (typ_all T U)). { rewrite* st.
  apply sub_reflexivity with (E:=empty); auto. subst. apply typing_regular in Typ. destruct Typ.
   destruct H0. auto. }
  clear st. gen_eq E: (@empty typ).
  induction Typ; introv EQE;
   try solve [ inversion Val | inversion EQE | eauto | inversion H ].
  exists e1. lets Q:(tall_inv H). destruct Q. subst*.
  subst. apply* IHTyp. eapply sub_transitivity. apply H0. apply H.
Qed.

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

Lemma progress_result : progress.
Proof.
  introv Typ. gen_eq E: (@empty bind). lets Typ': Typ.
  induction Typ; intros EQ; subst.
  (* case: var *)
  false* binds_empty_inv.
  (* case: abs *)
  left*.
  (* case: app *)
  right. destruct* IHTyp1 as [Val1 | [e1' Rede1']].
    destruct* IHTyp2 as [Val2 | [e2' Rede2']].
      destruct (canonical_form_abs Val1 Typ1) as [S [e3 EQ]].
        subst. exists* (open_ee e3 e2).
  (* case: tabs *)
  left*.
  (* case: tapp *)
  right. destruct* IHTyp as [Val1 | [e1' Rede1']].
    destruct (canonical_form_tabs Val1 Typ).
      subst. exists* (open_te x T).
  (* case: sub *)
  autos*.
Qed.


(** * Preliminaries to lBsystems. To be moved to upstream files later.

by Vladimir Voevodsky, file created on Jan. 6, 2015 *)

Require Import UniMath.Foundations.All.
Require Export UniMath.Combinatorics.StandardFiniteSets.

(* To upsetream files *)

Notation isaproptotal2 := ( isofhleveltotal2 1 ).

Lemma gth0_to_geh1 { n : nat } ( gt0 : n > 0 ): n >= 1.
Proof.
  induction n as [ | n IHn ] .
  - apply fromempty.
    apply ( negnatgthnn _ gt0 ).
  - apply ( natgehn0 n ).
Defined.

Lemma geh1_to_gth0 { n : nat } ( geh1 : n >= 1 ): n > 0.
Proof.
  apply ( natgehgthtrans _ _ _ geh1 ( natgthsnn 0 ) ).
Defined.

Lemma natminusind ( m n : nat ): m - S n = ( m - 1 ) - n.
Proof.
  induction m as [ | m IHm ].
  - apply idpath.
  - simpl.
    rewrite ( natminuseqn m ).
    apply idpath.
Defined.

Lemma natgthnnmius1 { n : nat } ( gt : n > 0 ): n > n - 1.
Proof.
  induction n as [ | n ].
  - induction ( negnatgthnn _ gt ).
  - change ( S n > n - 0 ).
    rewrite natminuseqn.
    exact ( natgthsnn _ ).
Defined.

Lemma natminusnn ( n : nat ): n - n = 0.
Proof.
  induction n as [ | n IHn ].
  - exact ( idpath _ ).
  - exact IHn.
Defined.

Lemma natminusmequalsn { m n : nat } ( ge : n >= m ) ( eq0 : n - m = 0 ): n = m.
Proof.
  revert n ge eq0.
  induction m as [ | m IHm ]; intros.
  - rewrite natminuseqn in eq0.
    exact eq0.
  - induction n as [ | n ].
    + destruct (nopathsfalsetotrue ge).
    + apply ( maponpaths S ).
      exact ( IHm n ge eq0 ).
Defined.

Lemma natmiusmius1mminus1 { n m : nat } ( gt1 : n > 0 ) ( gt2 : m > 0 ):
  ( n - 1 ) - ( m - 1 ) = n - m.
Proof.
  revert m gt1 gt2.
  induction n as [ | n IHn ]; intros.
  - destruct ( negnatgthnn _ gt1 ).
  - simpl.
    rewrite natminuseqn.
    induction m as [ | m ].
    + destruct ( negnatgthnn _ gt2 ).
    + simpl.
      rewrite natminuseqn.
      apply idpath.
Defined.

Lemma natgthtominus1geh { m n : nat }: m > n -> m - 1 >= n.
Proof.
  induction m as [ | m IHm ]; intro gt.
  - destruct (nopathsfalsetotrue gt).
  - change ( m - 0 >= n ).
    rewrite ( natminuseqn m ).
    apply natgthsntogeh.
    exact gt.
Defined.

Lemma natgthminus1togeh { n m : nat }: m > n - 1 -> m >= n.
Proof.
  induction n as [ | n IHn ].
  - intro gt.
    exact ( natgehn0 _ ).
  - intro gt.
    change ( S n - 1 ) with ( n - 0 ) in gt.
    rewrite ( natminuseqn n ) in gt.
    apply natgthtogehsn.
    exact gt.
Defined .

Lemma nat1plusminusgt { n m : nat } ( gt : 1 + m > n ): ( 1 + m ) - n = 1 + ( m - n ).
Proof.
  apply ( natplusrcan _ _ n ).
  rewrite ( natplusassoc _ _ n ).
  rewrite ( minusplusnmm _ n ( natgthtogeh _ _ gt ) ).
  rewrite ( minusplusnmm _ n ).
  - apply idpath.
  - apply ( natgthsntogeh _ _ gt ).
Defined.

Lemma lB_2014_12_07_l1 { m n : nat } ( gt : m > n ): m - n = 1 + (( m - 1 ) - n ).
Proof.
  induction m as [ | m IHm ].
  - destruct (nopathsfalsetotrue gt).
  - clear IHm.
    change ( S m - n = S ( m - 0 - n ) ).
    rewrite  ( natminuseqn m ).
    exact ( nat1plusminusgt gt ).
Defined.

Lemma natminusmmk { m k : nat } ( ge : m >= k ): m - ( m - k ) = k.
Proof.
  apply ( natplusrcan _ _ ( m - k ) ).
  rewrite minusplusnmm.
  - rewrite natpluscomm.
    rewrite minusplusnmm.
    + apply idpath.
    + apply ge.
  - apply natminuslehn.
Defined.

Lemma natleftplustorightminus ( n m k : nat ): n + m = k -> n = k - m.
Proof.
  intro e.
  assert ( ge : k >= m ).
  { rewrite <- e .
    exact ( natgehplusnmm _ _ ). }
  apply ( natplusrcan _ _ m ).
  rewrite ( minusplusnmm _ _ ge ).
  exact e .
Defined.

Definition natassocpmeq ( n m k : nat ) ( ge : m >= k ): ( n + m ) - k =  n + ( m - k ).
Proof.
  apply ( natplusrcan _ _ k ).
  rewrite ( natplusassoc n _ k ).
  rewrite ( minusplusnmm _ k ge ).
  set ( ge' := istransnatgeh _ _ _ ( natgehplusnmm n m ) ge ).
  rewrite ( minusplusnmm _ k ge' ).
  apply idpath.
Defined.

Definition natassocmpeq ( n m k : nat ) ( isnm : n >= m ) ( ismk : m >= k ):
  ( n - m ) + k = n - ( m - k ).
Proof.
  apply ( natplusrcan _ _ ( m - k ) ).
  assert ( is' : ( m - k ) <= n ) by
      apply ( istransnatleh (natminuslehn _ _ ) isnm ).
  rewrite ( minusplusnmm _ _ is' ).
  rewrite (natplusassoc _ k _ ).
  rewrite ( natpluscomm k _ ).
  rewrite ( minusplusnmm _ _ ismk ).
  rewrite ( minusplusnmm _ _ isnm ).
  apply idpath.
Defined.

Definition natminusassoc ( n m k : nat ): ( n  - m ) - k = n - ( m + k ).
Proof.
  revert n.
  induction m as [ | m IHm ]; intros.
  - simpl.
    rewrite ( natminuseqn n ).
    apply idpath.
  - rewrite ( natminusind n m ).
    rewrite ( IHm ( n - 1 ) ).
    rewrite ( ! ( natminusind _ _ ) ).
    apply idpath.
Defined.

Definition natminuscomm ( n m k : nat ): ( n - m ) - k = ( n - k ) - m.
Proof.
  rewrite natminusassoc.
  rewrite natminusassoc.
  rewrite natpluscomm.
  apply idpath.
Defined.

Definition natminusinter { n m k : nat } ( ge1 : n >= m ) ( ge2 : m >= k ):
  n - k = ( n - m ) + ( m - k ).
Proof.
  assert ( int1 : n - m + (m - k) = n - ( m - ( m - k ) ) ).
  { use natassocmpeq.
    - exact ge1 .
    - exact ( natminuslehn _ _ ).
  }
  assert ( int2 : m - ( m - k ) = k ) by exact ( natminusmmk ge2 ).
  rewrite int2 in int1.
  exact ( ! int1 ).
Defined.

(** [ nateq ] *)

Notation nateqandplusrinv := natplusrcan.

Notation nateqandpluslinv := natpluslcan.

Definition nateqandplusr ( n m k : nat ): n = m -> n + k = m + k :=
  maponpaths ( fun x => x + k ).

Definition nateqandplusl ( n m k : nat ): n = m -> k + n = k + m :=
  maponpaths ( fun x => k + x ).

(** **** Cancellation properties of minus on nat *)

Lemma natminusrcan { n m k : nat } ( ge1 : n >= k ) ( ge2 : m >= k ) ( is : n - k = m - k ):
  n = m.
Proof.
  assert ( is' := nateqandplusr _ _ k is ).
  rewrite ( minusplusnmm _ _ ge1 ) in is'.
  rewrite ( minusplusnmm _ _ ge2 ) in is'.
  exact is'.
Defined.

(* **** Greater and minus *)

Definition natgthrightminus ( n m k : nat ) ( ge : k >= m ): n + m > k -> n > k - m.
Proof.
  intro gt.
  apply ( natgthandplusrinv _ _ m ).
  rewrite ( minusplusnmm _ _ ge ).
  exact gt.
Defined.

Definition natgthrightplus ( n m k : nat ): n - m > k -> n > k + m.
Proof.
  intro gt.
  assert ( ge : n >= m ).
  { apply natgthtogeh.
    apply minusgth0inv.
    apply ( natgthgehtrans _ _ _ gt ( natgehn0 k ) ).
  }
  assert ( gt' : ( n - m ) + m > k + m ) by apply ( natgthandplusr _ _ _ gt ).
  rewrite ( minusplusnmm _ _ ge ) in gt'.
  exact gt'.
Defined.

Definition natgthleftminus ( n m k : nat ): n > m + k -> n - k > m.
Proof.
  intro gt.
  apply ( natgthandplusrinv _ _ k ).
  assert ( ge' : n >= k ).
  { apply natgthtogeh.
    exact ( natgthgehtrans _ _ _ gt ( natgehplusnmm _ _ ) ).
  }
  rewrite ( minusplusnmm _ _ ge' ).
  exact gt.
Defined.

Definition natgthleftplus ( n m k : nat ): n > m - k -> n + k > m.
Proof .
  intro gt.
  assert ( gt' : n + k > m - k + k ) by exact ( natgthandplusr _ _ k gt ).
  exact ( natgthgehtrans _ _ _ gt' ( minusplusnmmineq _ _ ) ).
Defined.

Definition natgthleftminusminus ( n m k : nat ): n - m > k -> n - k > m.
Proof.
  intro gt.
  assert ( gt' : n > k + m ) by exact ( natgthrightplus _ _ _ gt ).
  rewrite ( natpluscomm _ _ ) in gt'.
  exact ( natgthleftminus _ _ _ gt' ).
Defined.

(* **** Greater or equal and minus *)

Definition natgehrightminus ( n m k : nat ) ( ge : k >= m ): n + m >= k -> n >= k - m.
Proof.
  intro ge'.
  apply ( natgehandplusrinv _ _ m ).
  rewrite ( minusplusnmm _ _ ge ).
  exact ge'.
Defined.

Definition natgehrightplus ( n m k : nat ) ( ge : n >= m ): n - m >= k -> n >= k + m.
Proof.
  intro ge'.
  rewrite ( ! minusplusnmm _ _ ge ).
  apply ( natgehandplusr _ _ _ ).
  exact ge'.
Defined.

Definition natgehleftminus ( n m k : nat ): n >= m + k ->  n - k >= m.
Proof.
  intro ge.
  apply ( natgehandplusrinv _ _ k ).
  assert ( ge' : n >= k ) by exact ( istransnatgeh _ _ _ ge ( natgehplusnmm _ _ ) ).
  rewrite ( minusplusnmm _ _ ge' ).
  exact ge.
Defined.

Definition natgehleftplus ( n m k : nat ): n >= m - k -> n + k  >= m.
Proof.
  intro ge.
  assert ( ge' : n + k >= m - k + k ) by exact ( natgehandplusr _ _ k ge ).
  exact ( istransnatgeh _ _ _ ge' ( minusplusnmmineq _ _ ) ).
Defined .

Definition natgehleftminusminus ( n m k : nat ) ( ge : n >= m ): n - m >= k -> n - k >= m.
Proof .
  intro ge'.
  assert ( ge'' : n >= k + m ) by exact ( natgehrightplus _ _ _ ge ge' ).
  rewrite ( natpluscomm _ _ ) in ge''.
  exact ( natgehleftminus _ _ _ ge'' ).
Defined.

(* Two-sided minus and greater *)

Definition natgthandminusinvr { n m k : nat } ( is : n > m ) ( is' : m >= k ):
  n - k > m - k.
Proof.
  revert m k is is'.
  induction n as [ | n IHn ].
  - intros.
    destruct ( negnatgth0n _ is ).
  - intro m.
    induction k as [ | k ]; intros.
    + do 2 rewrite natminuseqn.
      exact is.
    + induction m as [ | m ].
      * destruct ( negnatgeh0sn _ is' ).
      * exact ( IHn m k is is' ).
Defined.

(* Two-sided minus and greater or equal *)

Definition natgehandminusl ( n m k : nat ) ( ge : n >= m ): k - m >= k - n.
Proof.
  revert m k ge.
  induction n as [ | n IHn ].
  - intros.
    rewrite ( nat0gehtois0 _ ge ).
    apply isreflnatleh.
  - induction m as [ | m ] .
    + intros.
      induction k as [ | k ].
      * apply natminuslehn.
      * apply natminuslehn.
    + induction k as [ | k ]; intro is.
      * apply isreflnatleh.
      * apply ( IHn m k ).
        apply is.
Defined.

Definition natgthandminuslinv { n m k : nat } ( gt : n - k > n - m ): m > k.
Proof.
  apply negnatlehtogth.
  intro ge.
  assert ( ge' : n - m >= n - k ) by exact ( natgehandminusl _ _ _ ge ).
  exact (natgthnegleh gt ge').
Defined.

(* Decrement function on nat *)

Definition dec ( n : nat ): nat :=
  match n with
      O => O |
    S n' => n'
  end.

(* End of the file lBsystems_prelim.v *)


From Hammer Require Import Hammer.

Set Implicit Arguments.

Local Notation PropositionalExtensionality :=
(forall A B : Prop, (A <-> B) -> A = B).

Local Notation ProvablePropositionExtensionality :=
(forall A:Prop, A -> A = True).

Local Notation RefutablePropositionExtensionality :=
(forall A:Prop, ~A -> A = False).

Local Notation PredicateExtensionality :=
(forall (A:Type) (P Q : A -> Prop), (forall x, P x <-> Q x) -> P = Q).

Local Notation PropositionalFunctionalExtensionality :=
(forall (A:Type) (P Q : A -> Prop), (forall x, P x = Q x) -> P = Q).

Lemma PredExt_imp_PropExt : PredicateExtensionality -> PropositionalExtensionality.
Proof. hammer_hook "PropExtensionalityFacts" "PropExtensionalityFacts.PredExt_imp_PropExt".
intros Ext A B Equiv.
change A with ((fun _ => A) I).
now rewrite Ext with (P := fun _ : True =>A) (Q := fun _ => B).
Qed.

Lemma PredExt_imp_PropFunExt : PredicateExtensionality -> PropositionalFunctionalExtensionality.
Proof. hammer_hook "PropExtensionalityFacts" "PropExtensionalityFacts.PredExt_imp_PropFunExt".
intros Ext A P Q Eq. apply Ext. intros x. now rewrite (Eq x).
Qed.

Lemma PropExt_and_PropFunExt_imp_PredExt :
PropositionalExtensionality -> PropositionalFunctionalExtensionality -> PredicateExtensionality.
Proof. hammer_hook "PropExtensionalityFacts" "PropExtensionalityFacts.PropExt_and_PropFunExt_imp_PredExt".
intros Ext FunExt A P Q Equiv.
apply FunExt. intros x. now apply Ext.
Qed.

Theorem PropExt_and_PropFunExt_iff_PredExt :
PropositionalExtensionality /\ PropositionalFunctionalExtensionality <-> PredicateExtensionality.
Proof. hammer_hook "PropExtensionalityFacts" "PropExtensionalityFacts.PropExt_and_PropFunExt_iff_PredExt".
firstorder using PredExt_imp_PropExt, PredExt_imp_PropFunExt, PropExt_and_PropFunExt_imp_PredExt.
Qed.

Lemma PropExt_imp_ProvPropExt : PropositionalExtensionality -> ProvablePropositionExtensionality.
Proof. hammer_hook "PropExtensionalityFacts" "PropExtensionalityFacts.PropExt_imp_ProvPropExt".
intros Ext A Ha; apply Ext; split; trivial.
Qed.

Lemma PropExt_imp_RefutPropExt : PropositionalExtensionality -> RefutablePropositionExtensionality.
Proof. hammer_hook "PropExtensionalityFacts" "PropExtensionalityFacts.PropExt_imp_RefutPropExt".
intros Ext A Ha; apply Ext; split; easy.
Qed.


Require Export Coq.Program.Tactics.
Require Export Coq.Setoids.Setoid.
Require Export Coq.Classes.Morphisms.
Require Export Coq.Arith.Arith_base.
Require Export Coq.Relations.Relations.
Require Export Coq.Lists.List.

Import EqNotations.
Import ListNotations.

(***
 *** Ordered Types = Types with a PreOrder
 ***)

Class OType (T:Type) : Type :=
  otype_rel : relation T.
(* Hint Mode OType + : typeclass_instances. *)

Definition ot_Type `(A:OType) : Type := T.
Coercion ot_Type : OType >-> Sortclass.

Definition ot_R `(A:OType) : relation A := otype_rel.

Class ValidOType `(A:OType) : Prop :=
  { ot_PreOrder :> PreOrder (ot_R A) }.
Hint Mode ValidOType + - : typeclass_instances.

(*
Instance PreOrder_OType `(valid:ValidOType) : PreOrder A.
Proof. auto with typeclass_instances. Qed.

Instance Reflexive_OType `(ValidOType) : Reflexive A.
Proof. auto with typeclass_instances. Qed.

Instance Transitive_OType `(ValidOType) : Transitive A.
Proof. auto with typeclass_instances. Qed.

Instance Reflexive_ValidOType {T} (A:relation T) (valid:ValidOType A) : Reflexive A.
Proof. auto with typeclass_instances. Qed.

Instance Transitive_ValidOType {T} (A:relation T) (valid:ValidOType A) : Transitive A.
Proof. auto with typeclass_instances. Qed.
 *)

(*
Instance PreOrder_ot_R `(valid:ValidOType) : PreOrder (ot_R A).
Proof. typeclasses eauto. Qed.
*)

(* The equivalence relation for an OrderedType *)
Definition ot_equiv `(A:OType) : relation A :=
  fun x y => ot_R A x y /\ ot_R A y x.

Instance ot_equiv_Equivalence `{ValidOType} : Equivalence (ot_equiv A).
Proof.
  constructor; intro; intros.
  { split; reflexivity. }
  { destruct H0; split; assumption. }
  { destruct H0; destruct H1; split; transitivity y; assumption. }
Qed.

(***
 *** Commonly-Used Ordered Types
 ***)

(* The ordered type of propositions *)
Instance OTProp : OType Prop := Basics.impl.
Instance Valid_OTProp : ValidOType OTProp.
Proof.
  constructor; constructor; typeclasses eauto.
Qed.

(* The discrete ordered type, where things are only related to themselves. NOTE:
we don't make this an instance, because we don't want proof search finding it
all the time... *)
Definition OTdiscrete T : OType T := eq.

Lemma Valid_OTdiscrete T : ValidOType (OTdiscrete T).
Proof.
  constructor; compute; typeclasses eauto.
Qed.

(* Tactic to apply Valid_OTdiscrete when we already have an OTdiscrete type *)
Hint Extern 1 (ValidOType (OTdiscrete _)) => apply Valid_OTdiscrete.

(* The only ordered type over unit is the discrete one *)
Instance OTunit : OType unit := OTdiscrete unit.
Instance Valid_OTunit : ValidOType OTunit := Valid_OTdiscrete unit.

(* The ordered type of natural numbers using <= *)
Instance OTnat : OType nat := le.
Instance Valid_OTnat : ValidOType OTnat.
Proof.
  constructor; typeclasses eauto.
Qed.

(* Flip the ordering of an OType *)
(* NOTE: we don't want this to be an instance, since applying it in proof search
leads to infinite regress... *)
Definition OTflip `(A:OType) : OType T := Basics.flip A.
Definition Valid_OTflip `(A:OType) (valid:ValidOType A) : ValidOType (OTflip A).
Proof.
  constructor. change (PreOrder (Basics.flip (ot_R A))). typeclasses eauto.
Qed.

(* Tactic to apply Valid_OTflip when we already have an OTflip type *)
Hint Extern 1 (ValidOType (OTflip _)) => apply Valid_OTflip : typeclass_instances.

(* Avoid infinite regress from repeatedly applying Valid_OTflip *)
(*
Hint Cut [ !*; Valid_OTflip; Valid_OTflip ] : typeclass_instances.
*)

(* The non-dependent product ordered type, where pairs are related pointwise *)
Instance OTpair {TA} (A:OType TA) {TB} (B:OType TB) : OType (TA*TB) :=
  fun p1 p2 => ot_R A (fst p1) (fst p2) /\ ot_R B (snd p1) (snd p2).

Instance Valid_OTpair `(A:OType) `(B: OType) (vA:ValidOType A)
         (vB:ValidOType B) : ValidOType (OTpair A B).
Proof.
  repeat constructor; try reflexivity.
  { destruct H; destruct H0; transitivity (fst y); assumption. }
  { destruct H; destruct H0; transitivity (snd y); assumption. }
Qed.

(* The non-dependent sum ordered type, where objects are only related if they
are both "left"s or both "right"s *)
Instance OTsum {TA TB} (A:OType TA) (B:OType TB) : OType (TA+TB) :=
  fun sum1 sum2 =>
    match sum1, sum2 with
    | inl x, inl y => ot_R A x y
    | inl x, inr y => False
    | inr x, inl y => False
    | inr x, inr y => ot_R B x y
    end.

Instance Valid_OTsum `(A:OType) `(B:OType)
         (vA:ValidOType A) (vB:ValidOType B) : ValidOType (OTsum A B).
Proof.
  repeat constructor; unfold ot_R, otype_rel, OTsum.
  { intro s; destruct s; simpl; reflexivity. }
  { intros s1 s2 s3 R12 R23.
    destruct s1; destruct s2; destruct s3;
      try (elimtype False; assumption); simpl.
    - transitivity t0; assumption.
    - transitivity t0; assumption. }
Qed.

(* NOTE: the following definition requires everything above to be polymorphic *)
(* NOTE: The definition we choose for OTType is actually deep: instead of
requiring ot_Type A = ot_Type B, we could just require a coercion function from
ot_Type A to ot_Type B, which would yield something more like HoTT... though
maybe it wouldn't work unless we assumed the HoTT axiom? As it is, we might need
UIP to hold if we want to use the definition given here... *)
(*
Program Definition OTType : OType :=
  {|
    ot_Type := OType;
    ot_R := (fun A B =>
               exists (e:ot_Type A = ot_Type B),
                 forall (x y:A),
                   ot_R A x y ->
                   ot_R B (rew [fun A => A] e in x)
                        (rew [fun A => A] e in y));
  |}.
*)

(***
 *** The Ordered Type for Functions
 ***)

(* The type of continuous, i.e. Proper, functions between ordered types *)
Record Pfun `(A:OType) `(B: OType) :=
  {
    pfun_app : A -> B;
    pfun_Proper :> Proper (ot_R A ==> ot_R B) pfun_app
  }.

Arguments pfun_app [_ _ _ _] _ _.
Arguments pfun_Proper [_ _ _ _] _ _ _ _.

(* Infix "@" := pfun_app (at level 50). *)

(* The non-dependent function ordered type *)
Instance OTarrow `(A:OType) `(B:OType) : OType (Pfun A B) :=
  fun f g =>
    forall a1 a2, ot_R A a1 a2 -> ot_R B (pfun_app f a1) (pfun_app g a2).

Instance Valid_OTarrow `(A:OType) `(B:OType)
  (vA:ValidOType A) (vB:ValidOType B) : ValidOType (OTarrow A B).
Proof.
  repeat constructor.
  { intros f; apply (pfun_Proper f). }
  { intros f g h Rfg Rgh a1 a2 Ra; transitivity (pfun_app g a1).
    - apply (Rfg a1 a1). reflexivity.
    - apply Rgh; assumption. }
Qed.

(* Curry a Pfun *)
Program Definition pfun_curry `(A:OType) `(B:OType) `(C:OType)
        {vA:ValidOType A} {vB:ValidOType B} {vC:ValidOType C}
        (pfun : Pfun (OTpair A B) C) : Pfun A (OTarrow B C) :=
  {| pfun_app :=
       fun a =>
         {| pfun_app := fun b => pfun_app pfun (a,b);
            pfun_Proper := _ |};
     pfun_Proper := _ |}.
Next Obligation.
Proof.
  intros b1 b2 Rb. apply pfun_Proper.
  split; [ reflexivity | assumption ].
Qed.
Next Obligation.
Proof.
  intros a1 a2 Ra b1 b2 Rb; simpl.
  apply pfun_Proper; split; assumption.
Qed.

(* Uncrry a Pfun *)
Program Definition pfun_uncurry `(A:OType) `(B:OType) `(C:OType)
        {vA:ValidOType A} {vB:ValidOType B} {vC:ValidOType C}
        (pfun : Pfun A (OTarrow B C)) : Pfun (OTpair A B) C :=
  {| pfun_app :=
       fun ab => pfun_app (pfun_app pfun (fst ab)) (snd ab);
     pfun_Proper := _ |}.
Next Obligation.
Proof.
  intros ab1 ab2 Rab. destruct Rab as [ Ra Rb ].
  exact (pfun_Proper pfun (fst ab1) (fst ab2) Ra (snd ab1) (snd ab2) Rb).
Qed.

(* Currying and uncurrying of pfuns form an adjunction *)
(* FIXME HERE: figure out the simplest way of stating this adjunction *)

(* OTarrow is right adjoint to OTpair, meaning that (OTarrow (OTpair A B) C) is
isomorphic to (OTarrow A (OTarrow B C)). The following is the first part of this
isomorphism, mapping left-to-right. *)

(* FIXME: could also do a forall type, but need the second type argument, B, to
itself be proper, i.e., to be an element of OTarrow A OType. Would also need a
dependent version of OTContext, below. *)

(***
 *** Ordered Type Functions
 ***)

Class OTypeF (TF: forall `(A:OType), Type) : Type :=
  otypef_app : forall `(A:OType), OType (TF A).

Arguments otypef_app [TF] _ [T] A _ _.

Instance OType_OTypeF_app `(F:OTypeF) `(A:OType) : OType (TF _ A) := otypef_app _ A.

Class ValidOTypeF `(F:OTypeF) : Prop :=
  {
    otypef_app_PreOrder :>
      forall `(A:OType) {_:ValidOType A}, PreOrder (ot_R (otypef_app F A))
  }.

Instance ValidOType_OTypeF_app `(ValidOTypeF) `(ValidOType) :
  ValidOType (otypef_app F A).
Proof.
  constructor. typeclasses eauto.
Qed.

(***
 *** Notations for Ordered Types
 ***)

Module OTNotations.

  Notation "A '-o>' B" :=
    (OTarrow A B) (right associativity, at level 99).
  Notation "A '*o*' B" :=
    (OTpair A B) (left associativity, at level 40).
  Notation "A '+o+' B" :=
    (OTsum A B) (left associativity, at level 50).
  Notation "'~o~' A" :=
    (OTflip A) (right associativity, at level 35).

  Notation "x <o= y" :=
    (ot_R _ x y) (no associativity, at level 70).
  Notation "x =o= y" :=
    (ot_equiv _ x y) (no associativity, at level 70).

  Notation "x @o@ y" :=
    (pfun_app x y) (left associativity, at level 20).

  Notation "F @t@ A" :=
    (otypef_app F A) (left associativity, at level 20).

End OTNotations.

(***
 *** Building Proper Functions
 ***)

Class OTEnrich `(A:OType) {AU} (RU:relation AU) : Type :=
  {
    ot_lift : forall a, Proper RU a -> T;
    ot_lift_Proper :
      forall a1 a2 prp1 prp2,
        RU a1 a2 -> ot_R A (ot_lift a1 prp1) (ot_lift a2 prp2);
    ot_unlift : T -> AU;
  }.

Arguments OTEnrich {T} A {AU%type} RU%signature.

Program Instance OTEnrich_refl `(A:OType) : OTEnrich A (ot_R A) :=
  {
    ot_lift := fun a _ => a;
    ot_lift_Proper := _;
    ot_unlift := fun a => a;
  }.

Program Instance OTEnrich_fun `(A:OType) `(B:OType) BU RBU
        (vA:ValidOType A) (ote:@OTEnrich _ B BU RBU) :
  OTEnrich (OTarrow A B) (ot_R A ==> RBU) :=
  {
    ot_lift := fun f prp =>
                 {| pfun_app :=
                      fun a => ot_lift (OTEnrich:=ote) (f a) _ |};
    ot_lift_Proper := _;
    ot_unlift := fun pfun a => ot_unlift (pfun_app pfun a);
  }.
Next Obligation.
  apply prp. reflexivity.
Qed.
Next Obligation.
  intros a1 a2 Ra. apply ot_lift_Proper. apply prp. assumption.
Qed.
Next Obligation.
  intros x1 x2 Rx. apply ot_lift_Proper. apply H. assumption.
Qed.

(* Tactic to prove OTEnrich goals *)
Ltac prove_OTEnrich :=
  lazymatch goal with
  | |- @OTEnrich _ _ (_ -> _) _ => apply OTEnrich_fun
  | |- OTEnrich ?A ?B => apply OTEnrich_refl
  end.

(* Hint to use the prove_OTEnrich tactic; we need this because often the
relation part is an evar, so will not match any of the instances above *)
Hint Extern 1 (OTEnrich _ _) => prove_OTEnrich : typeclass_instances.

Class OTHasType `(A:OType) {AU} (RU:relation AU) (x y:AU) : Type :=
  {
    ot_wf_type : OTEnrich A RU;
    ot_wf_term : RU x y;
  }.

Arguments OTHasType {_} A {AU%type} RU%signature x y.

(* NOTE: We only want this to apply to terms that are syntactically lambdas, so
we use an Extern hint, below. *)
Definition OTHasType_lambda `(A:OType) `(B:OType)
           {vA:ValidOType A} BU RBU `{@OTEnrich _ B BU RBU}
         (fl fr:T -> BU)
         (pf: forall xl xr (pf:OTHasType A (ot_R A) xl xr),
             OTHasType B RBU (fl xl) (fr xr)) :
  OTHasType (OTarrow A B) (ot_R A ==> RBU) fl fr.
Proof.
  constructor.
  typeclasses eauto.
  intros xl xr Rx. apply pf. constructor.
  typeclasses eauto.
  assumption.
Defined.

Instance OTHasType_app `(A:OType) AU RAU `(B:OType) BU RBU
         (fl fr:AU -> BU) argl argr
         `{@OTEnrich _ B BU RBU}
         `{@OTHasType _ (OTarrow A B) _ (RAU ==> RBU) fl fr}
         `{@OTHasType _ A _ RAU argl argr}
 : OTHasType B RBU (fl argl) (fr argr) | 3.
Proof.
  constructor.
  assumption.
  apply H0. apply ot_wf_term.
Defined.

Instance OTHasType_pfun_app `(A:OType) `(B:OType) (fl fr:OTarrow A B) argl argr
         (otef:OTHasType (OTarrow A B) (ot_R (OTarrow A B)) fl fr)
         (otea:OTHasType A (ot_R A) argl argr)
 : OTHasType B (ot_R B) (pfun_app fl argl) (pfun_app fr argr) | 2.
Proof.
  constructor.
  typeclasses eauto.
  apply (ot_wf_term (OTHasType:=otef)).
  apply (ot_wf_term (OTHasType:=otea)).
Defined.

(*
Ltac OTHasType_tac :=
  lazymatch goal with
  | |- OTHasType _ _ (fun x => ?f) (fun y => ?g) =>
    eapply (OTHasType_lambda _ _ _ _ (fun x => f) (fun y => g))
  | |- OTHasType _ _ (pfun_app ?f ?x) (pfun_app ?g ?y) =>
    apply (OTHasType_pfun_app _ _ f g x y)
  | |- OTHasType _ _ (?f ?x) (?g ?y) =>
    eapply (OTHasType_app _ _ _ _ _ _ f g x y)
  end.

Hint Extern 4 (OTHasType _ _ _ _) => OTHasType_tac : typeclass_instances.
*)

(* Hint to apply OTHasType_lambda on lambdas *)
Ltac try_OTHasType_lambda :=
  lazymatch goal with
  | |- OTHasType _ _ (fun x => ?f) (fun y => ?g) =>
    eapply (OTHasType_lambda _ _ _ _ (fun x => f) (fun y => g))
  end.

Hint Extern 2 (OTHasType _ _ (fun _ => _) (fun _ => _)) =>
try_OTHasType_lambda : typeclass_instances.

(* NOTE: this is not an instance because it is not syntax-driven, like our other
rules for OTHasType. Instead, this definition is used as a helper to build
other instances of OTHasType. *)
Definition OTHasType_Proper `{OTEnrich} (x:AU) :
  Proper RU x -> OTHasType A RU x x.
  intros; constructor; assumption.
Defined.

Instance OTHasType_refl `(vA:ValidOType) (x:T) : OTHasType A (ot_R A) x x.
Proof.
  apply OTHasType_Proper. unfold Proper. reflexivity.
Defined.

(*
Instance OTHasType_refl_rel {T} (A:relation T) {vA:ValidOType A} (x:T)
  : OTHasType A A x x := OTHasType_refl A x.
*)

Program Definition mkOTerm `(A:OType) {AU RU} (x:AU)
        `{@OTHasType _ A AU RU x x} : ot_Type A :=
  ot_lift (OTEnrich:=ot_wf_type) x ot_wf_term.

Arguments mkOTerm {_} A {AU%type RU%signature} x {H}.

(***
 *** OT Typing Rules for Common Operations
 ***)

(*
Instance OTHasType_Proper A AU R (x:AU)
           {ote:OTEnrich A R} {prp:Proper R x} :
  OTHasType A R x x.
  constructor; assumption.
Qed.

Instance Proper_fst A B : Proper (ot_R (OTpair A B) ==> ot_R A) fst.
Proof.
  intros p1 p2 Rp; destruct Rp; assumption.
Qed.

Instance Proper_snd A B : Proper (ot_R (OTpair A B) ==> ot_R B) snd.
Proof.
  intros p1 p2 Rp; destruct Rp; assumption.
Qed.

Instance Proper_pair A B : Proper (ot_R A ==> ot_R B ==> ot_R (OTpair A B)) pair.
Proof.
  intros a1 a2 Ra b1 b2 Rb; split; assumption.
Qed.
*)

Instance OTHasType_fst `{ValidOType} `{ValidOType} :
  OTHasType (OTarrow (OTpair A A0) A) (ot_R (OTpair A A0) ==> ot_R A) fst fst.
Proof.
  apply OTHasType_Proper.
  intros p1 p2 Rp; destruct Rp; assumption.
Defined.

Instance OTHasType_snd `{ValidOType} `{ValidOType} :
  OTHasType (OTarrow (OTpair A A0) A0) (ot_R (OTpair A A0) ==> ot_R A0) snd snd.
Proof.
  apply OTHasType_Proper.
  intros p1 p2 Rp; destruct Rp; assumption.
Defined.

Instance OTHasType_pair `{ValidOType} `{ValidOType} :
  OTHasType (OTarrow A (OTarrow A0 (OTpair A A0)))
            (ot_R A ==> ot_R A0 ==> ot_R (OTpair A A0)) pair pair.
Proof.
  apply OTHasType_Proper.
  intros a1 a2 Ra b1 b2 Rb; split; assumption.
Defined.

(***
 *** Examples of Ordered Terms
 ***)

Module OTExamples.
Import OTNotations.

Definition ex1 := mkOTerm (OTProp -o> OTProp) (fun p => p).
Eval compute in (ot_unlift ex1 : Prop -> Prop).

Definition ex2 `{ValidOType} := mkOTerm (A -o> A) (fun p => p).
Eval simpl in (fun `{ValidOType} => ot_unlift ex2 : A -> A).

Definition ex3 `{A:OType} {_:ValidOType A} :=
  mkOTerm (A -o> A -o> A -o> A -o> A) (fun p1 p2 p3 p4 => p1).
Eval simpl in (fun `(A:OType) => ot_unlift ex3 : A -> A  -> A -> A -> A).

Definition ex4 `{A:OType} `{B:OType} {_:ValidOType A} {_:ValidOType B}
  : (A *o* B -o> A) :=
  mkOTerm _ (fun p => fst p).
Eval simpl in (fun `{ValidOType} `{ValidOType} =>
                 ot_unlift ex4 : T * T0 -> T).

(*
Definition blah {A B:OType} {R}
           `{OTHasType (A *o* B -o> B *o* A) _ R
                       (fun p : A * B => (snd p, fst p))
                       (fun p => (snd p, fst p))} : Prop := True.
Definition blah2 {A B} : Prop := blah (A:=A) (B:=B).
 *)

Definition ex5 `{A:OType} `{B:OType} {_:ValidOType A} {_:ValidOType B}
  : A *o* B -o> B *o* A :=
  mkOTerm _ (fun p => (snd p, fst p)).
Eval simpl in (fun `{ValidOType} `{ValidOType} =>
                 ot_unlift ex5 : A *o* A0 -> A0 *o* A).

Definition ex6 `{A:OType} `{B:OType} `{C:OType}
           {_:ValidOType A} {_:ValidOType B} {_:ValidOType C}
  : A *o* B *o* C -o> C *o* A :=
  mkOTerm _ (fun triple => (snd triple, fst (fst triple))).

Set Printing All. Typeclasses eauto := debug.

Definition ex7 `{A:OType} `{B:OType} `{C:OType}
           {_:ValidOType A} {_:ValidOType B} {_:ValidOType C}
  : (A *o* B -o> C) -o> C -o> A -o> B -o> C :=
  mkOTerm _
          (fun f c a b => f @o@ (a, b)).

End OTExamples.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.

Import WfExtensionality.

Lemma subtype_equ_upp_reduce :
  forall T1 L1 T1', T1 = (t_equ L1 T1') ->
               forall T2 L2 T2', T2 = (t_upp L2 T2') ->
                            subtype T1 T2 = (eq_label L1 L2) && subtype T1' T2'.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.


Require Import Init.Init.
Require Import Relation.Relation.

Definition suc (A: J) := A ∪ (`{A}).
Notation   "S( x )"   := (suc(x)).

Definition inductive (A: J) := ∅ ∈ A ∧ ∀ x, x ∈ A → S(x) ∈ A.

Definition trans (A: J) := ∀ x, ∀ a, x ∈ a → a ∈ A → x ∈ A.

(* Successor *)
Lemma suc_e: ∀ A, ∀ x, x ∈ S(A) → x = A ∨ x ∈ A.
Proof.
  intros A x P1.
  destruct (union2_e _ _ _ P1) as [P2 | P2].
  + right.
    apply P2.
  + left.
    apply eq_s.
    apply (sing_e _ _ P2).
Qed.

Lemma suc_i1: ∀ A, A ∈ S(A).
Proof.
  intros A.
  apply union2_ir.
  apply sing_i.
Qed.

Lemma suc_i2: ∀ A, ∀ x, x ∈ A → x ∈ S(A).
Proof.
  intros A x P1.
  apply (union2_il _ _ _ P1).
Qed.

Lemma suc_i3: ∀ A, A ⊆ S(A).
Proof.
  intros A x P1.
  apply (suc_i2 _ _ P1).
Qed.

Lemma empty_not_suc: ∀ x, ∅ ≠ S(x).
Proof.
  intros x P1.
  apply (empty_i x).
  apply (eq_cr (λ y, x ∈ y) P1).
  apply suc_i1.
Qed.

Lemma suc_kick_self: ∀ A, S(A) \ `{A} = A.
Proof.
  intros A.
  apply sub_a.
  split.
  + intros x P1.
    destruct (compl_e _ _ _ P1) as [P2 P3].
    destruct (suc_e _ _ P2) as [P4 | P4].
    - apply bot_e.
      apply P3.
      apply (eq_cr (λ x, x ∈ `{A}) P4).
      apply sing_i.
    - apply P4.
  + intros x P1.
    apply compl_i.
    - apply (suc_i2 _ _ P1).
    - intros P2.
      apply (nin_self A).
      apply (eq_cr (λ x, x ∈ A) (sing_e _ _ P2)).
      apply P1.
Qed.
(*----------------------------------------------------------------------------*)

(* Transition *)
Lemma trans_e1: ∀ A, trans A → ∪(A) ⊆ A.
Proof.
  intros A P1 x P2.
  destruct (union_e A x P2) as [a [P3 P4]].
  apply (P1 _ _ P4 P3).
Qed.

Lemma trans_e2: ∀ A, trans A → ∀ a, a ∈ A → a ⊆ A.
Proof.
  intros A P1 a P2 x P3.
  apply (P1 _ _ P3 P2).
Qed.

Lemma trans_e3: ∀ A, trans A → A ⊆ 𝒫(A).
Proof.
  intros A P1 x P2.
  apply power_i.
  apply (trans_e2 _ P1 _ P2).
Qed.

Lemma trans_i1: ∀ A, ∪(A) ⊆ A → trans A.
Proof.
  intros A P1 x a P2 P3.
  apply P1.
  apply union_i.
  exists a.
  apply (and_i P3 P2).
Qed.

Lemma trans_i2: ∀ A, (∀ a, a ∈ A → a ⊆ A) → trans A.
Proof.
  intros A P1 x a P2 P3.
  apply (P1 _ P3 x P2).
Qed.

Lemma trans_i3: ∀ A, A ⊆ 𝒫(A) → trans A.
Proof.
  intros A P1 x a P2 P3.
  apply (power_e _ _ (P1 _ P3) x P2).
Qed.

Lemma union_trans_suc: ∀ A, trans A → ∪(S(A)) = A.
Proof.
  intros A P1.
  apply sub_a.
  split.
  + intros x P2.
    destruct (union_e _ _ P2) as [y [P3 P4]].
    destruct (suc_e _ _ P3) as [P5|P5].
    - apply (eq_cl _ P5).
      apply P4.
    - apply (P1 _ _ P4 P5).
  + intros x P2.
    apply union_i.
    exists A.
    split.
    - apply suc_i1.
    - apply P2.
Qed.

Lemma empty_is_trans: trans ∅.
Proof.
  intros x y P1 P2.
  apply bot_e.
  apply (empty_i _ P2).
Qed.

Lemma suc_trans: ∀ A, trans A → trans (S(A)).
Proof.
  intros A P1.
  apply trans_i2.
  intros a P2 x P3.
  destruct (suc_e _ _ P2) as [P4 | P4].
  + apply suc_i2.
    apply (eq_cl (λ s, x ∈ s) P4).
    apply P3.
  + apply suc_i2.
    apply (P1 _ _ P3 P4).
Qed.
(*----------------------------------------------------------------------------*)


Require Import
        Coq.Lists.List
        Coq.Strings.String
        Coq.Setoids.Setoid
        Coq.Arith.PeanoNat
        Coq.omega.Omega
        Coq.setoid_ring.Ring
        Coq.setoid_ring.Ring_theory
        Matrix
        SparseMatrix
        DenseMatrix
        FiatHelpers
        MyHelpers
        MatrixLemmas
        optimize_ADT.

Section AlphaBetaFilter.
  Variable n : nat.
  Context {ME : MatrixElem}.
  Variable DT : SDM n.
  Variable Alpha : SDM n.
  Variable Beta : SDM n.

  Record ABState :=
    { x : Vt n;
      v : Vt n }.

  Definition ABSig : ADTSig :=
    ADTsignature {
      Constructor "Init" : ABState -> rep,
      Method "Predict"   : rep   -> rep * (Vt n),
      Method "Update"    : rep * (Vt n)  -> rep * unit
    }.

  Definition ABSpec : ADT ABSig :=
    Def ADT {
      rep := ABState,

      Def Constructor1 "Init" (init_state: ABState): rep := ret init_state,,

      Def Method0 "Predict" (r : rep) : rep * (Vt n) :=
        x' <<- r.(x);
        xx <- {X | X @= x'};
        ret (r, xx),

      Def Method1 "Update" (r : rep) (x_: Vt n): rep * unit :=
	x' <<- r.(x) &+ DT @* r.(v);
	v' <<- r.(v);
	rk <<- x_ &- x';
	x' <<- x' &+ Alpha @* rk;
	v' <<- v' &+ Beta @* rk;
	ret ({| x := x'; v := v' |}, tt)
        }%methDefParsing.

  Record NState :=
    { Sx : Vt n;
      Sv : Vt n }.

  Definition use_a_sparse_P (or : ABState) (nr : NState) :=
    or.(x) @= nr.(Sx) /\ or.(v) @= nr.(Sv).

  Definition SharpenedAB :
    FullySharpened ABSpec.
  Proof.
    Optimize_ADT ABState NState use_a_sparse_P.
  Defined.

  Definition ABImpl : ComputationalADT.cADT ABSig :=
    Eval simpl in projT1 SharpenedAB.

  Print ABImpl.

End AlphaBetaFilter.


From mathcomp Require Import ssreflect ssrbool ssrnat seq.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Lemma singleton_seq A (l : seq A) :
  size l = 1%N -> exists x : A, l = x :: nil.
Proof.
  elim: l => //=.
  move=> hd tl; elim tl => //=.
  move=> _ _; exists hd.
  reflexivity.
Qed.

Lemma last_decomp A (l : seq A) (n : nat) :
  size l = (n + 1)%N -> exists s x, l = rcons s x.
Proof.
  move: l n. apply: last_ind => /=.
  - by case.
  - move=> l x IH n H. exists l; exists x; reflexivity.
Qed.

Lemma last_default_irrelevant A (l : seq A) (n : nat) b1 b2 :
  size l = (n + 1)%N -> last b1 l = last b2 l.
Proof.
  move: l n b1 b2. apply: last_ind => /=.
  - move=> n b1 b2; by case n.
  - move=> l lst IH n b1 b2 H. rewrite !last_rcons. reflexivity.
Qed.


From Coq Require Import Description.

Lemma exclusive_dec: forall P Q:Prop, ~(P /\ Q) ->
  (P \/ Q) -> {P} + {Q}.
Proof.
intros.
assert ({x:bool | if x then P else Q}).
{ apply constructive_definite_description.
  case H0.
  - exists true.
    red; split.
    + assumption.
    + destruct x'.
      * reflexivity.
      * tauto.
  - exists false.
    red; split.
    + assumption.
    + destruct x'.
      * tauto.
      * reflexivity.
}
destruct H1.
destruct x; [left|right]; assumption.
Qed.

Lemma decidable_dec: forall P:Prop, P \/ ~P -> {P} + {~P}.
Proof.
intros.
apply exclusive_dec; tauto.
Qed.

From Coq Require Import Classical.

Lemma classic_dec: forall P:Prop, {P} + {~P}.
Proof.
intro P.
apply decidable_dec.
apply classic.
Qed.


From Coq Require Import Eqdep_dec.
From OLlibs Require Import List_more.

Set Implicit Arguments.

Lemma injection_list_Forall_inf_cons A P :
  (forall x y : A, { x = y } + { x <> y }) ->
  forall (a : A) l p p' (F F' : Forall_inf P l),
  Forall_inf_cons a p F = Forall_inf_cons a p' F' -> p = p' /\ F = F'.
Proof.
intros Hdec a l p p' F F' [= Heq Heql]; split.
- apply (inj_pair2_eq_dec _ Hdec _ _ _ _ Heq).
- apply (inj_pair2_eq_dec _ (list_eq_dec Hdec) _ _ _ _ Heql).
Qed.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Arith Relations Lia.

Require Import Undecidability.Synthetic.Definitions.
Require Import Undecidability.Synthetic.ReducibilityFacts.

From Undecidability.Shared.Libs.DLW Require Import utils pos vec sss subcode.
From Undecidability.MinskyMachines Require Import mma_defs mma_simul.

Set Implicit Arguments.

Theorem MMA2_MMA2_HALTS_ON_ZERO : MMA2_HALTING ⪯ MMA2_HALTS_ON_ZERO.
Proof.
  apply reduces_dependent; exists.
  intros (P,v).
  destruct mma2_simulator with 1 1 P as (Q & HQ).
  exists (Q,v); apply HQ.
Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)
(*                      Evgeny Makarov, INRIA, 2007                     *)
(************************************************************************)

Require Export ZBase.

Module ZAddProp (Import Z : ZAxiomsMiniSig').
Include ZBaseProp Z.

(** Theorems that are either not valid on N or have different proofs
    on N and Z *)

Hint Rewrite opp_0 : nz.

Theorem add_pred_l : forall n m, P n + m == P (n + m).
Proof.
intros n m.
rewrite <- (succ_pred n) at 2.
now rewrite add_succ_l, pred_succ.
Qed.

Theorem add_pred_r : forall n m, n + P m == P (n + m).
Proof.
intros n m; rewrite 2 (add_comm n); apply add_pred_l.
Qed.

Theorem add_opp_r : forall n m, n + (- m) == n - m.
Proof.
nzinduct m.
now nzsimpl.
intro m. rewrite opp_succ, sub_succ_r, add_pred_r. now rewrite pred_inj_wd.
Qed.

Theorem sub_0_l : forall n, 0 - n == - n.
Proof.
intro n; rewrite <- add_opp_r; now rewrite add_0_l.
Qed.

Theorem sub_succ_l : forall n m, S n - m == S (n - m).
Proof.
intros n m; rewrite <- 2 add_opp_r; now rewrite add_succ_l.
Qed.

Theorem sub_pred_l : forall n m, P n - m == P (n - m).
Proof.
intros n m. rewrite <- (succ_pred n) at 2.
rewrite sub_succ_l; now rewrite pred_succ.
Qed.

Theorem sub_pred_r : forall n m, n - (P m) == S (n - m).
Proof.
intros n m. rewrite <- (succ_pred m) at 2.
rewrite sub_succ_r; now rewrite succ_pred.
Qed.

Theorem opp_pred : forall n, - (P n) == S (- n).
Proof.
intro n. rewrite <- (succ_pred n) at 2.
rewrite opp_succ. now rewrite succ_pred.
Qed.

Theorem sub_diag : forall n, n - n == 0.
Proof.
nzinduct n.
now nzsimpl.
intro n. rewrite sub_succ_r, sub_succ_l; now rewrite pred_succ.
Qed.

Theorem add_opp_diag_l : forall n, - n + n == 0.
Proof.
intro n; now rewrite add_comm, add_opp_r, sub_diag.
Qed.

Theorem add_opp_diag_r : forall n, n + (- n) == 0.
Proof.
intro n; rewrite add_comm; apply add_opp_diag_l.
Qed.

Theorem add_opp_l : forall n m, - m + n == n - m.
Proof.
intros n m; rewrite <- add_opp_r; now rewrite add_comm.
Qed.

Theorem add_sub_assoc : forall n m p, n + (m - p) == (n + m) - p.
Proof.
intros n m p; rewrite <- 2 add_opp_r; now rewrite add_assoc.
Qed.

Theorem opp_involutive : forall n, - (- n) == n.
Proof.
nzinduct n.
now nzsimpl.
intro n. rewrite opp_succ, opp_pred. now rewrite succ_inj_wd.
Qed.

Theorem opp_add_distr : forall n m, - (n + m) == - n + (- m).
Proof.
intros n m; nzinduct n.
now nzsimpl.
intro n. rewrite add_succ_l; do 2 rewrite opp_succ; rewrite add_pred_l.
now rewrite pred_inj_wd.
Qed.

Theorem opp_sub_distr : forall n m, - (n - m) == - n + m.
Proof.
intros n m; rewrite <- add_opp_r, opp_add_distr.
now rewrite opp_involutive.
Qed.

Theorem opp_inj : forall n m, - n == - m -> n == m.
Proof.
intros n m H. apply opp_wd in H. now rewrite 2 opp_involutive in H.
Qed.

Theorem opp_inj_wd : forall n m, - n == - m <-> n == m.
Proof.
intros n m; split; [apply opp_inj | intros; now f_equiv].
Qed.

Theorem eq_opp_l : forall n m, - n == m <-> n == - m.
Proof.
intros n m. now rewrite <- (opp_inj_wd (- n) m), opp_involutive.
Qed.

Theorem eq_opp_r : forall n m, n == - m <-> - n == m.
Proof.
symmetry; apply eq_opp_l.
Qed.

Theorem sub_add_distr : forall n m p, n - (m + p) == (n - m) - p.
Proof.
intros n m p; rewrite <- add_opp_r, opp_add_distr, add_assoc.
now rewrite 2 add_opp_r.
Qed.

Theorem sub_sub_distr : forall n m p, n - (m - p) == (n - m) + p.
Proof.
intros n m p; rewrite <- add_opp_r, opp_sub_distr, add_assoc.
now rewrite add_opp_r.
Qed.

Theorem sub_opp_l : forall n m, - n - m == - m - n.
Proof.
intros n m. rewrite <- 2 add_opp_r. now rewrite add_comm.
Qed.

Theorem sub_opp_r : forall n m, n - (- m) == n + m.
Proof.
intros n m; rewrite <- add_opp_r; now rewrite opp_involutive.
Qed.

Theorem add_sub_swap : forall n m p, n + m - p == n - p + m.
Proof.
intros n m p. rewrite <- add_sub_assoc, <- (add_opp_r n p), <- add_assoc.
now rewrite add_opp_l.
Qed.

Theorem sub_cancel_l : forall n m p, n - m == n - p <-> m == p.
Proof.
intros n m p. rewrite <- (add_cancel_l (n - m) (n - p) (- n)).
rewrite 2 add_sub_assoc. rewrite add_opp_diag_l; rewrite 2 sub_0_l.
apply opp_inj_wd.
Qed.

Theorem sub_cancel_r : forall n m p, n - p == m - p <-> n == m.
Proof.
intros n m p.
stepl (n - p + p == m - p + p) by apply add_cancel_r.
now do 2 rewrite <- sub_sub_distr, sub_diag, sub_0_r.
Qed.

(** The next several theorems are devoted to moving terms from one
    side of an equation to the other. The name contains the operation
    in the original equation ([add] or [sub]) and the indication
    whether the left or right term is moved. *)

Theorem add_move_l : forall n m p, n + m == p <-> m == p - n.
Proof.
intros n m p.
stepl (n + m - n == p - n) by apply sub_cancel_r.
now rewrite add_comm, <- add_sub_assoc, sub_diag, add_0_r.
Qed.

Theorem add_move_r : forall n m p, n + m == p <-> n == p - m.
Proof.
intros n m p; rewrite add_comm; now apply add_move_l.
Qed.

(** The two theorems above do not allow rewriting subformulas of the
    form [n - m == p] to [n == p + m] since subtraction is in the
    right-hand side of the equation. Hence the following two
    theorems. *)

Theorem sub_move_l : forall n m p, n - m == p <-> - m == p - n.
Proof.
intros n m p; rewrite <- (add_opp_r n m); apply add_move_l.
Qed.

Theorem sub_move_r : forall n m p, n - m == p <-> n == p + m.
Proof.
intros n m p; rewrite <- (add_opp_r n m). now rewrite add_move_r, sub_opp_r.
Qed.

Theorem add_move_0_l : forall n m, n + m == 0 <-> m == - n.
Proof.
intros n m; now rewrite add_move_l, sub_0_l.
Qed.

Theorem add_move_0_r : forall n m, n + m == 0 <-> n == - m.
Proof.
intros n m; now rewrite add_move_r, sub_0_l.
Qed.

Theorem sub_move_0_l : forall n m, n - m == 0 <-> - m == - n.
Proof.
intros n m. now rewrite sub_move_l, sub_0_l.
Qed.

Theorem sub_move_0_r : forall n m, n - m == 0 <-> n == m.
Proof.
intros n m. now rewrite sub_move_r, add_0_l.
Qed.

(** The following section is devoted to cancellation of like
    terms. The name includes the first operator and the position of
    the term being canceled. *)

Theorem add_simpl_l : forall n m, n + m - n == m.
Proof.
intros; now rewrite add_sub_swap, sub_diag, add_0_l.
Qed.

Theorem add_simpl_r : forall n m, n + m - m == n.
Proof.
intros; now rewrite <- add_sub_assoc, sub_diag, add_0_r.
Qed.

Theorem sub_simpl_l : forall n m, - n - m + n == - m.
Proof.
intros; now rewrite <- add_sub_swap, add_opp_diag_l, sub_0_l.
Qed.

Theorem sub_simpl_r : forall n m, n - m + m == n.
Proof.
intros; now rewrite <- sub_sub_distr, sub_diag, sub_0_r.
Qed.

Theorem sub_add : forall n m, m - n + n == m.
Proof.
 intros. now rewrite <- add_sub_swap, add_simpl_r.
Qed.

(** Now we have two sums or differences; the name includes the two
    operators and the position of the terms being canceled *)

Theorem add_add_simpl_l_l : forall n m p, (n + m) - (n + p) == m - p.
Proof.
intros n m p. now rewrite (add_comm n m), <- add_sub_assoc,
sub_add_distr, sub_diag, sub_0_l, add_opp_r.
Qed.

Theorem add_add_simpl_l_r : forall n m p, (n + m) - (p + n) == m - p.
Proof.
intros n m p. rewrite (add_comm p n); apply add_add_simpl_l_l.
Qed.

Theorem add_add_simpl_r_l : forall n m p, (n + m) - (m + p) == n - p.
Proof.
intros n m p. rewrite (add_comm n m); apply add_add_simpl_l_l.
Qed.

Theorem add_add_simpl_r_r : forall n m p, (n + m) - (p + m) == n - p.
Proof.
intros n m p. rewrite (add_comm p m); apply add_add_simpl_r_l.
Qed.

Theorem sub_add_simpl_r_l : forall n m p, (n - m) + (m + p) == n + p.
Proof.
intros n m p. now rewrite <- sub_sub_distr, sub_add_distr, sub_diag,
sub_0_l, sub_opp_r.
Qed.

Theorem sub_add_simpl_r_r : forall n m p, (n - m) + (p + m) == n + p.
Proof.
intros n m p. rewrite (add_comm p m); apply sub_add_simpl_r_l.
Qed.

(** Of course, there are many other variants *)

End ZAddProp.