Require Export Coq.Relations.Relation_Definitions.
Require Export Coq.Relations.Relation_Operators.
Require Export Coq.Relations.Relation_Definitions.
Require Export Coq.Classes.RelationClasses.
Require Import Coq.Arith.Even.
Require Import Coq.Arith.Div2.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Omega.

Definition image_defined {A B} (R: A -> B -> Prop): Prop :=
  forall a, exists b, R a b.

Definition partial_functional {A B} (R: A -> B -> Prop): Prop :=
  forall a b1 b2, R a b1 -> R a b2 -> b1 = b2.

Definition injective {A B} (R: A -> B -> Prop): Prop :=
  forall a1 a2 b, R a1 b -> R a2 b -> a1 = a2.

Definition surjective {A B} (R: A -> B -> Prop): Prop :=
  forall b, exists a, R a b.

Definition function_injective {A B} (f: A -> B): Prop :=
  forall a1 a2, f a1 = f a2 -> a1 = a2.

Definition function_surjective {A B} (f: A -> B): Prop :=
  forall b, exists a, f a = b.

Record injection (A B: Type): Type := {
  inj_R:> A -> B -> Prop;
  im_inj: image_defined inj_R;
  pf_inj: partial_functional inj_R;
  in_inj: injective inj_R
}.

Record surjection (A B: Type): Type := {
  sur_R:> A -> B -> Prop;
  im_surj: image_defined sur_R;
  pf_surj: partial_functional sur_R;
  su_surj: surjective sur_R
}.

Record bijection (A B: Type): Type := {
  bij_R:> A -> B -> Prop;
  im_bij: image_defined bij_R;
  pf_bij: partial_functional bij_R;
  in_bij: injective bij_R;
  su_bij: surjective bij_R
}.

Definition FBuild_injection (A B: Type) (f: A -> B) (H: function_injective f): injection A B.
  apply (Build_injection _ _ (fun a b => f a = b)).
  + hnf; intros; eauto.
  + hnf; intros; congruence.
  + hnf; intros.
    apply H; congruence.
Defined.

Definition FBuild_surjection (A B: Type) (f: A -> B) (H: function_surjective f): surjection A B.
  apply (Build_surjection _ _ (fun a b => f a = b)).
  + hnf; intros; eauto.
  + hnf; intros; congruence.
  + hnf; intros.
    apply H; congruence.
Defined.

Definition FBuild_bijection (A B: Type) (f: A -> B) (H: function_injective f) (H0: function_surjective f): bijection A B.
  apply (Build_bijection _ _ (fun a b => f a = b)).
  + hnf; intros; eauto.
  + hnf; intros; congruence.
  + hnf; intros.
    apply H; congruence.
  + hnf; intros.
    apply H0.
Defined.

Definition injection_trans {A B C} (R1: injection A B) (R2: injection B C): injection A C.
  intros.
  apply (Build_injection _ _ (fun a c => exists b, R1 a b /\ R2 b c)).
  + hnf; intros.
    destruct (im_inj _ _ R1 a) as [b ?].
    destruct (im_inj _ _ R2 b) as [c ?].
    exists c; eauto.
  + hnf; intros a c1 c2 [b1 [? ?]] [b2 [? ?]].
    pose proof pf_inj _ _ R1 a b1 b2 H H1.
    subst b2.
    pose proof pf_inj _ _ R2 b1 c1 c2 H0 H2.
    auto.
  + hnf; intros a1 a2 c [b1 [? ?]] [b2 [? ?]].
    pose proof in_inj _ _ R2 b1 b2 c H0 H2.
    subst b2.
    pose proof in_inj _ _ R1 a1 a2 b1 H H1.
    auto.
Defined.

Definition bijection_sym {A B} (R: bijection A B): bijection B A.
  apply (Build_bijection _ _ (fun a b => R b a)).
  + hnf.
    apply (su_bij _ _ R).
  + hnf; intros.
    apply (in_bij _ _ R b1 b2 a); auto.
  + hnf; intros.
    apply (pf_bij _ _ R b a1 a2); auto.
  + hnf.
    apply (im_bij _ _ R).
Defined.

Definition bijection_refl {A}: bijection A A.
  apply (Build_bijection _ _ eq).
  + hnf; intros.
    eauto.
  + hnf; intros.
    congruence.
  + hnf; intros.
    congruence.
  + hnf; intros.
    eauto.
Defined.

Definition sum_injection {A1 B1 A2 B2} (R1: injection A1 B1) (R2: injection A2 B2): injection (sum A1 A2) (sum B1 B2).
Proof.
  intros.
  apply (Build_injection _ _ (fun a b =>
          match a, b with
          | inl a, inl b => R1 a b
          | inr a, inr b => R2 a b
          | _, _ => False
          end)).
  + hnf; intros.
    destruct a as [a | a].
    - destruct (im_inj _ _ R1 a) as [b ?].
      exists (inl b); auto.
    - destruct (im_inj _ _ R2 a) as [b ?].
      exists (inr b); auto.
  + hnf; intros.
    destruct a as [a | a], b1 as [b1 | b1], b2 as [b2 | b2]; try solve [inversion H | inversion H0].
    - f_equal; apply (pf_inj _ _ R1 a); auto.
    - f_equal; apply (pf_inj _ _ R2 a); auto.
  + hnf; intros.
    destruct a1 as [a1 | a1], a2 as [a2 | a2], b as [b | b]; try solve [inversion H | inversion H0].
    - f_equal; apply (in_inj _ _ R1 _ _ b); auto.
    - f_equal; apply (in_inj _ _ R2 _ _ b); auto.
Defined.

Definition prod_injection {A1 B1 A2 B2} (R1: injection A1 B1) (R2: injection A2 B2): injection (prod A1 A2) (prod B1 B2).
Proof.
  intros.
  apply (Build_injection _ _ (fun a b => R1 (fst a) (fst b) /\ R2 (snd a) (snd b))).
  + hnf; intros.
    destruct (im_inj _ _ R1 (fst a)) as [b1 ?].
    destruct (im_inj _ _ R2 (snd a)) as [b2 ?].
    exists (b1, b2); auto.
  + hnf; intros.
    destruct b1, b2, H, H0.
    pose proof pf_inj _ _ R1 (fst a) _ _ H H0.
    pose proof pf_inj _ _ R2 (snd a) _ _ H1 H2.
    simpl in *; subst; auto.
  + hnf; intros.
    destruct a1, a2, H, H0.
    pose proof in_inj _ _ R1 _ _ _ H H0.
    pose proof in_inj _ _ R2 _ _ _ H1 H2.
    simpl in *; subst; auto.
Defined.

Definition sigT_injection (I: Type) (A: I -> Type) (B: Type) (R: forall i: I, injection (A i) B): injection (sigT A) (I * B).
  apply (Build_injection _ _ (fun a b => projT1 a = fst b /\ (R (projT1 a)) (projT2 a) (snd b))).
  + hnf; intros.
    destruct a as [i a0].
    destruct (im_inj _ _ (R i) a0) as [b0 ?].
    exists (i, b0).
    auto.
  + hnf; intros.
    destruct b1 as [i1 b1]; simpl in H.
    destruct b2 as [i2 b2]; simpl in H0.
    destruct H, H0; subst.
    pose proof pf_inj _ _ (R (projT1 a)) _ _ _ H1 H2.
    subst; auto.
  + hnf; intros.
    destruct b, H, H0; simpl in *; subst.
    destruct a1, a2; simpl in *; subst.
    pose proof in_inj _ _ (R x) _ _ _ H1 H2.
    subst; auto.
Qed.

Definition bijection_injection {A B} (R: bijection A B): injection A B :=
  Build_injection _ _ R (im_bij _ _ R) (pf_bij _ _ R) (in_bij _ _ R).

Definition nat2_nat_bijection: bijection (sum nat nat) nat.
  apply (Build_bijection _ _ (fun n m => match n with | inl n => m = n + n | inr n => m = n + n +1 end)).
  + hnf; intros.
    destruct a; eauto.
  + hnf; intros.
    destruct a; inversion H; inversion H0; auto.
  + hnf; intros.
    destruct a1, a2; inversion H; inversion H0; destruct (lt_eq_lt_dec n n0) as [[? | ?] | ?]; try omega; subst; auto.
  + hnf; intros.
    destruct (Even.even_odd_dec b) as [H | H].
    - rewrite (proj1 (Div2.even_odd_double _)), NPeano.double_twice in H.
      exists (inl (Div2.div2 b)).
      rewrite H at 1. omega.
    - rewrite (proj2 (Div2.even_odd_double _)), NPeano.double_twice in H.
      exists (inr (Div2.div2 b)).
      rewrite H at 1. omega.
Defined.

Definition natnat_nat_bijection: bijection (prod nat nat) nat.
  apply (Build_bijection _ _
          (fun n m => m = match n with | (n1, n2) =>
                            (fix sum (x: nat): nat := match x with | O => O | S x => S x + sum x end)
                              (n1 + n2)
                            + n1
                          end)).
  + hnf; intros.
    destruct a; eauto.
  + hnf; intros.
    destruct a; omega.
  + hnf; intros.
    destruct a1 as [a11 a12], a2 as [a21 a22].
    assert (forall m1 m2, m1 < m2 ->
      (fix sum (x : nat) : nat :=
          match x with
          | 0 => 0
          | S x0 => S x0 + sum x0
          end) m1 + m1 <
      (fix sum (x : nat) : nat :=
          match x with
          | 0 => 0
          | S x0 => S x0 + sum x0
          end) m2).
    {
      intros.
      remember (m2 - m1 - 1) as d; assert (m2 = (S d) + m1) by omega.
      subst m2; clear.
      induction d.
      + simpl.
        omega.
      + simpl in *.
        omega.
    }
    destruct (lt_eq_lt_dec (a11 + a12) (a21 + a22)) as [[HH | HH] | HH].
    - specialize (H1 _ _ HH).
      omega.
    - rewrite HH in H.
      assert (a11 = a21) by omega.
      assert (a12 = a22) by omega.
      subst; auto.
    - specialize (H1 _ _ HH).
      omega.
  + hnf; intros.
    assert (exists s,
        (fix sum (x : nat) : nat :=
          match x with
          | 0 => 0
          | S x0 => S x0 + sum x0
          end) s <= b <
        (fix sum (x : nat) : nat :=
          match x with
          | 0 => 0
          | S x0 => S x0 + sum x0
          end) (S s)).
    {
      induction b.
      + exists 0; simpl.
        omega.
      + destruct IHb as [s ?].
        remember (b - (fix sum (x : nat) : nat :=
                         match x with
                         | 0 => 0
                         | S x0 => S x0 + sum x0
                         end) s) as d.
        destruct (lt_dec d s) as [HH | HH].
        - exists s; simpl in *; omega.
        - exists (S s); simpl in *; omega.
    }
    destruct H as [s ?].
    remember (b - (fix sum (x : nat) : nat :=
                match x with
                | 0 => 0
                | S x0 => S x0 + sum x0
                end) s) as a1.
    exists (a1, s - a1).
    replace (a1 + (s - a1)) with s by omega.
    omega.
Defined.


(*
MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Section Exercise_Eighteen.

Coq < Goal forall a d b f c e:Prop, (((~a \/ d) -> (b -> f)) /\ ((b \/ c) -> (a -> e)) /\ (a \/ b) /\ (~a)) -> (e \/ f).
1 subgoal

  ============================
   forall a d b f c e : Prop,
   (~ a \/ d -> b -> f) /\ (b \/ c -> a -> e) /\ (a \/ b) /\ ~ a -> e \/ f

Unnamed_thm < intros.
1 subgoal

  a : Prop
  d : Prop
  b : Prop
  f : Prop
  c : Prop
  e : Prop
  H : (~ a \/ d -> b -> f) /\ (b \/ c -> a -> e) /\ (a \/ b) /\ ~ a
  ============================
   e \/ f

Unnamed_thm < elim H.
1 subgoal

  a : Prop
  d : Prop
  b : Prop
  f : Prop
  c : Prop
  e : Prop
  H : (~ a \/ d -> b -> f) /\ (b \/ c -> a -> e) /\ (a \/ b) /\ ~ a
  ============================
   (~ a \/ d -> b -> f) -> (b \/ c -> a -> e) /\ (a \/ b) /\ ~ a -> e \/ f

Unnamed_thm < intro.
1 subgoal

  a : Prop
  d : Prop
  b : Prop
  f : Prop
  c : Prop
  e : Prop
  H : (~ a \/ d -> b -> f) /\ (b \/ c -> a -> e) /\ (a \/ b) /\ ~ a
  H0 : ~ a \/ d -> b -> f
  ============================
   (b \/ c -> a -> e) /\ (a \/ b) /\ ~ a -> e \/ f

Unnamed_thm < intro.
1 subgoal

  a : Prop
  d : Prop
  b : Prop
  f : Prop
  c : Prop
  e : Prop
  H : (~ a \/ d -> b -> f) /\ (b \/ c -> a -> e) /\ (a \/ b) /\ ~ a
  H0 : ~ a \/ d -> b -> f
  H1 : (b \/ c -> a -> e) /\ (a \/ b) /\ ~ a
  ============================
   e \/ f

Unnamed_thm < destruct H1.
1 subgoal

  a : Prop
  d : Prop
  b : Prop
  f : Prop
  c : Prop
  e : Prop
  H : (~ a \/ d -> b -> f) /\ (b \/ c -> a -> e) /\ (a \/ b) /\ ~ a
  H0 : ~ a \/ d -> b -> f
  H1 : b \/ c -> a -> e
  H2 : (a \/ b) /\ ~ a
  ============================
   e \/ f

Unnamed_thm < right.
1 subgoal

  a : Prop
  d : Prop
  b : Prop
  f : Prop
  c : Prop
  e : Prop
  H : (~ a \/ d -> b -> f) /\ (b \/ c -> a -> e) /\ (a \/ b) /\ ~ a
  H0 : ~ a \/ d -> b -> f
  H1 : b \/ c -> a -> e
  H2 : (a \/ b) /\ ~ a
  ============================
   f

Unnamed_thm < firstorder.
No more subgoals.

Unnamed_thm < Qed.
intros.
elim H.
intro.
intro.
right.
firstorder .

Unnamed_thm is defined

Coq <

*)

Section Exercise_Eighteen.
Goal forall a d b f c e:Prop, (((~a \/ d) -> (b -> f)) /\ ((b \/ c) -> (a -> e)) /\ (a \/ b) /\ (~a)) -> (e \/ f).
intros.
elim H.
intro.
intro.
right.
firstorder.
Qed.


Require Export refine.
Require Export parser.

Require Export Station.
Require Export Vehicle.

(** The CyCab example *)

Definition FVehicle: IA := parse
 "IA [s1,s2,s3,s4,s5,s6] (s1) [fstart,start,emrg,far,halt] [pos,reset] [move,stop]
  [s1->(start)s2, s2->(move)s3, s2->(emrg)s5, s3->(pos)s4, s3->(emrg)s5, s4->(far)s2,
  s4->(halt)s1, s4->(emrg)s5, s5->(reset)s1, s1->(fstart)s6, s6->(move)s6, s6->(emrg)s5,
  s6->(stop)s1]".

Eval compute in IAutomaton.b_compatible FVehicle Station.

Definition FVehicle_Station: IA :=IAutomaton.composition FVehicle Station.
Eval compute in :> FVehicle_Station.

(*********** security of FVehicle*Station ******************************************)

(*************************** \Gamma(fstart)=m ****************************)
(* SIR-GNNI at m: true *)
Definition FVehicle_Station_hid_m: IA :=
 IAutomaton.hiding FVehicle_Station (ASet.GenActs [&"emrg",&"reset"]).

Definition FVehicle_Station_res_m: IA :=
 IAutomaton.hiding
 ( IAutomaton.restriction FVehicle_Station (ASet.GenActs [&"emrg"]) )
 (ASet.GenActs [&"reset"]).

Eval compute in :> FVehicle_Station_hid_m.
Eval compute in :> FVehicle_Station_res_m.
Eval compute in SIRGNNI_refinement FVehicle_Station_res_m FVehicle_Station_hid_m.

(* SME-NI at m: true *)
Definition FVehicle_Station_rep_m: IA :=
 IAutomaton.hiding
 ( IAutomaton.replacement FVehicle_Station (&"tau") (ASet.GenActs [&"emrg"]) )
 (ASet.GenActs [&"reset"]).

Eval compute in :> FVehicle_Station_rep_m.
Eval compute in SMENI_refinement FVehicle_Station_rep_m FVehicle_Station_hid_m.

(* SIR-GNNI at l: true *)
Definition FVehicle_Station_hid_l: IA :=
  IAutomaton.hiding FVehicle_Station
  (ASet.GenActs [&"emrg",&"start",&"fstart",&"reset"]).

Definition FVehicle_Station_res_l: IA :=
  IAutomaton.hiding
  ( IAutomaton.restriction FVehicle_Station (ASet.GenActs [&"emrg",&"start",&"fstart"]) )
  (ASet.GenActs [&"reset"]).

Eval compute in :>FVehicle_Station_hid_l.
Eval compute in :>FVehicle_Station_res_l.
Eval compute in SIRGNNI_refinement FVehicle_Station_res_l FVehicle_Station_hid_l.

(* SME-NI at l: true *)
Definition FVehicle_Station_rep_l: IA :=
  IAutomaton.hiding
  ( IAutomaton.replacement FVehicle_Station (&"tau") (ASet.GenActs [&"emrg",&"start",&"fstart"]) )
  (ASet.GenActs [&"reset"]).

Eval compute in :>FVehicle_Station_rep_l.
Eval compute in SMENI_refinement FVehicle_Station_rep_l FVehicle_Station_hid_l.


(**************************************************************************************************
* Preservation and Progress for duotyped System-F with duotyping                                    *
* 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 types *)

Inductive Mode := Sub | Sup.

Definition flip (m : Mode) : Mode :=
  match m with
  | Sub => Sup
  | Sup => Sub
  end.

Inductive typ : Set :=
  | typ_btm   : typ
  | typ_top   : typ
  | typ_int   : typ
  | typ_arrow : typ -> typ -> typ
  | typ_bvar  : nat -> typ
  | typ_fvar  : var -> typ
  | typ_all   : Mode -> 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 : Mode -> 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_btm         => typ_btm
  | typ_top         => typ_top
  | typ_int         => typ_int
  | 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 m T1 T2 => typ_all m (open_tt_rec K U T1)(open_tt_rec (S 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 m T e => trm_tabs m (open_tt_rec K U T) (open_te_rec (S K) U e)
  | 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 m T t => trm_tabs m T (open_ee_rec k f t)
  | trm_tapp t  T => trm_tapp (open_ee_rec k f t) T
  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).

Inductive bind : Set :=
  | bind_tRel : Mode -> typ -> bind
  | bind_typ : typ -> bind.

Notation "X !: m <>: T" := (X ~ bind_tRel m T)
  (at level 23, left associativity) : env_scope.

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

Definition env := LibEnv.env bind.

Definition mode_to_sub m := match m with
  | Sub => typ_top
  | Sup => typ_btm end.

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

Inductive type : typ -> Prop :=
  | type_top :
      type typ_top
  | type_int :
      type typ_int
  | type_btm :
      type typ_btm
  | 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 m L T1 T2,
      type T1 ->
      (forall X, X \notin L -> type (T2 open_tt_var X)) ->
      type (typ_all m 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 m T L e1, type T ->
      (forall X, X \notin L -> term (e1 open_te_var X)) ->
      term (trm_tabs m T e1)
  | term_tapp : forall e1 V,
      term e1 ->
      type V ->
      term (trm_tapp e1 V).

(** Binding map term variables to types, and keeps type variables in the environment.
 [x ~: T] is a typing assumption *)

(** 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 m T1 E X,
      binds X (bind_tRel m T1) E ->
      wft E (typ_fvar X)
  | wft_int : forall E,
      wft E typ_int
  | wft_btm :forall E,
      wft E typ_btm
  | wft_arrow : forall E T1 T2,
      wft E T1 ->
      wft E T2 ->
      wft E (typ_arrow T1 T2)
  | wft_all : forall L E T m Tn,
      wft E Tn ->
      (forall X, X \notin L ->
        wft (E & X !: m <>: Tn) (T open_tt_var X)) ->
      wft E (typ_all m Tn T).

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

Definition BindPosVariance m1 m2 :=
  match m1 with
    | Sup => m2
    | Sub => flip m2 end.

Definition SelectBound m2 (S1:typ) (S2:typ) :=
  match m2 with
    | Sup => S1
    | Sub => S2 end.

Inductive R : env -> Mode -> typ -> typ -> Prop :=
| SInt : forall E m, okt E -> R E m typ_int typ_int
| STB1 : forall E A m, okt E ->wft E A ->R E m A (mode_to_sub m)
| STB2 : forall E A m, okt E -> wft E A ->R E m (mode_to_sub (flip m)) A
| SFun : forall E A B C D m, R E (flip m) A C -> R E m B D -> R E m (typ_arrow A B) (typ_arrow C D)
| SVarRefl : forall E X m, okt E -> wft E (typ_fvar X) -> R E m (typ_fvar X) (typ_fvar X)
| SVarBnd : forall E X m T F, binds X (bind_tRel m T) E -> wft E T -> R E m T F -> R E m (typ_fvar X) F
| SVarBndFl :  forall E X m T F, binds X (bind_tRel m T) E -> wft E T -> R E m T F -> R E (flip m) F (typ_fvar X)
(* | SVarTrns : forall E X m T1 T2 , R E m T1 (typ_fvar X) -> R E m (typ_fvar X) T2 -> R E m T1 T2 *)
| SAll : forall E L m1 m2 T1 T2 T3 T4, (*wft E T1 -> wft E T2 ->*)
  R E (BindPosVariance m1 m2) T1 T2 ->
(forall X, X \notin L ->
  R (E&(X !: m1 <>: (SelectBound m2 T1 T2))) m2 (T3 open_tt_var X) (T4 open_tt_var X))->
  R E m2 (typ_all m1 T1 T3) (typ_all m1 T2 T4).

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 m Tk E e T,
      (forall X, X \notin L ->
        typing (E & X!: m <>: Tk) (e open_te_var X) (T open_tt_var X)) ->
      typing E (trm_tabs m Tk e) (typ_all m Tk T)
  | typing_tapp : forall m E Tb T1 T2 e,
    typing E e (typ_all m Tb T1) ->
    R E m T2 Tb ->
    typing E (trm_tapp e T2) (open_tt T1 T2)
  | typing_sub : forall S E e T,
      typing E e S ->
      R E Sub S T ->
      wft E 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 m T e, term (trm_tabs m T e) ->
                 value (trm_tabs m T e).

(** One-step reduction *)

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

(** 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'.

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

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

Fixpoint fv_tt (T : typ) {struct T} : vars :=
  match T with
  | 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)
  | _           => \{}
  end.

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

Fixpoint fv_te (e : trm) {struct e} : vars :=
  match e with
  | trm_abs V e1  => (fv_tt V) \u (fv_te e1)
  | trm_app e1 e2 => (fv_te e1) \u (fv_te e2)
  | trm_tabs m T e1   =>  (fv_tt T) \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 m T t    => fv_ee t
  | trm_tapp t1 _ => (fv_ee t1)
  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_int         => typ_int
  | typ_btm         => typ_btm
  | 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 m T1 T2  => typ_all m (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 m T e => trm_tabs m (subst_tt Z U T) (subst_te Z U e)
  | 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 m T t=> trm_tabs m T (subst_ee z u t)
  | trm_tapp t1 T => trm_tapp (subst_ee z u t1) T
  end.

Definition subst_tb (Z : var) (P : typ) (b : bind) : bind :=
  match b with
  | bind_tRel m T => bind_tRel m (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
  STB1 STB2 SInt SFun SVarRefl
  typing_var typing_app typing_sub typing_tapp.

(** 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
  | |- R ?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*.

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

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

(** 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.

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 type_all with (L:=L \u \{Z}). apply* IHtype.
  intros. 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 term_tabs with (L:=L \u \{Z}). auto.
  intros. 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 term_tabs with (L:=L \u \{Z}). auto. intros. 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 m T1 (E0&F&G)). apply* binds_weaken. autos*.
  (* 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. assert (wft G T). { auto. }
  induction H; intros F EQ; subst; auto.
  apply (@wft_var m T1). destruct (binds_concat_inv H) as [?|[? ?]].
    apply* binds_concat_right.
    destruct (binds_push_inv H2) as [[? ?]|[? ?]].
      subst. false.
      apply~ binds_concat_left.
  autos*.
  (* todo: binds_cases tactic *)
  apply_fresh* wft_all as Y. apply_ih_bind* H2.
Qed.

(** Through type substitution *)

Lemma wft_subst_tb : forall m T1 F E Z P T,
  wft (E & Z !:m  <>: T1 & 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 !:m <>: T1 & F). gen F.
  induction WT; intros F EQ Ok; subst; simpl subst_tt; auto.
  case_var*.
    apply_empty* wft_weaken.
     destruct (binds_concat_inv H) as [?|[? ?]].
      apply wft_var with (m:=m0) (T1:=(subst_tt Z P T0)).
       apply~ binds_concat_right.
      unsimpl_map_bind. apply~ binds_map.
      destruct (binds_push_inv H1) as [[? ?]|[? ?]].
        subst. false~.
        applys wft_var. apply* binds_concat_left.
  apply_fresh* wft_all as Y.
   unsimpl ((subst_tb Z P) (bind_tRel m0 Tn)).
   lets: wft_type.
   rewrite* subst_tt_open_tt_var.
   apply_ih_map_bind* H0.
Qed.

(** Through type reduction *)

Lemma wft_open : forall E U m T1 T2,
  ok E ->
  wft E (typ_all m 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 m T1 empty).
  specializes_vars K. clean_empty K. apply* K.
  (* todo: apply empty ? *)
Qed.

(** Through narrowing *)

Lemma wft_narrow : forall m V F U T E X,
  wft (E & X !: m <>: V & F) T ->
  ok (E & X !: m <>: U & F) ->
  wft (E & X !: m <>: U & F) T.
Proof.
  intros. gen_eq K: (E & X !: m <>: 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 typing 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 m U E,
  okt E -> binds x (bind_tRel m 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 m x T E,
  okt (E & x !: m <>: 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.

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

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

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

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

(** Inversion lemma *)

Lemma okt_push_inv : forall E X B,
  okt (E & X ~ B) -> (exists m T, B = bind_tRel m 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 m T,
  okt (E & X !:m <>: 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 m E X T,
  okt (E & X !: m <>: 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.

Hint Immediate okt_push_typ_type okt_push_sub_type.
(** Through strengthening *)

Lemma okt_strengthen : forall x T (E F:env),
  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. destruct H. subst.
     lets (?&?): (okt_push_tvr_inv O).
      applys~ okt_tvr. 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.
    destruct H. subst.
     lets (?&?): (okt_push_tvr_inv OKC). apply IHF. apply H.
      lets (?&?): (okt_push_typ_inv OKC). apply* IHF.
Qed.

Lemma okt_subst_tb : forall Q m Z P (E F:env),
  okt (E & Z!: m <>: 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.
   destruct H. subst. lets (?&?): (okt_push_tvr_inv O).
      applys~ okt_tvr. destruct* H0. autos*.
      lets (?&?&?): (okt_push_typ_inv O).
      applys~ okt_typ. apply* wft_subst_tb.
Qed.

Lemma okt_narrow : forall m V (E F:env) U X,
  okt (E & X !: m <>: V & F) ->
  wft E U ->
  okt (E & X !: m <>: 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_tvr. applys* wft_narrow.
     lets (?&?&?): (okt_push_typ_inv O).
      applys~ okt_typ. applys* wft_narrow.
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.
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.
  auto. auto. auto.
  notin_simpl; auto.
 notin_simpl; auto. pick_fresh Y. apply* (@notin_fv_tt_open Y).
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 m T1 T2,
  R E m T1 T2 -> okt E /\ wft E T1 /\ wft E T2.
Proof. introv Rel.
induction Rel; autos*.
  - destruct m; autos*.
  - destruct m; autos*.
  - split. destruct IHRel; auto. split; apply_fresh* wft_all as Y.
    destruct (H0 Y); auto. destruct H2. destruct m2; simpl in H2.
    apply_empty* (@wft_narrow m1 T2); autos. autos.
    destruct (H0 Y); auto. destruct H2. destruct m2; simpl in H3.
    autos. apply_empty* (@wft_narrow m1 T1); autos. Qed.

Lemma sub_wft : forall E m T1 T2,
  R E m T1 T2 -> wft E T1 /\ wft E T2.
Proof. intros. apply sub_regular in H. destruct H; auto. 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.
     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_wft in H0.
  destruct H0. apply H0.
  destruct IHtyping. destruct H2. inversion H3.  subst.
   applys* wft_open T2. apply sub_wft 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: R _ _ _ _ |- _ => 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: R E _ T _ |- _ => apply (proj32 (sub_regular H))
  | H: R 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: R ?E _ T _ |- _ => go E
  | H: R ?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.

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

(* ********************************************************************** *)
(** Reflexivity (1) *)
Lemma refl : forall E m A,
  okt E ->
  wft E A ->
  R E m A A.
  introv OK WFT. lets W:(wft_type WFT). gen E. gen m.
  induction W; intros; inversion WFT; eauto.
  - destruct m. apply* STB1. apply* STB2.
  - destruct m. apply* STB2. apply* STB1.
  - subst. pick_fresh X. apply SAll with (L:=L\u L0 \u dom E).
    auto. intros v Hv. apply notin_union_r in Hv. destruct Hv.
    apply notin_union_r in H2. destruct H2.
    apply H0 with (E:=E & v!:m<>:(SelectBound m0 T1 T1)); auto.
    destruct m0; auto.
    destruct m0; auto.
Defined.

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

Lemma sub_weakening : forall m E F G S T,
   R (E & G) m S T ->
   okt (E & F & G) ->
   R (E & F & G) m S T.
Proof.
  introv Typ. gen F. inductions Typ; introv Ok; auto.
  (* case: fvar trans *)
  apply SVarBnd with (T:=T). apply* binds_weaken.
  autos. autos.
  apply SVarBndFl with (T:=T). apply* binds_weaken.
  autos. autos.
  (* case: all *)
  apply SAll with (L:=L \u (dom E) \u (dom F) \u (dom G)). auto. intros.
  assert (E & F & G & X !: m1 <>: (SelectBound m2 T1 T2) = E&F&(G & X !: m1<>:(SelectBound m2 T1 T2))).
  rewrite concat_assoc. reflexivity. rewrite H2. apply H0; auto.
  rewrite concat_assoc. auto. rewrite concat_assoc. apply* okt_tvr.
  destruct m2; simpl. auto. auto.
Qed.

(* ********************************************************************** *)
(** Symmetry*)

Lemma m_flip_inv : forall m, m = flip (flip m).
Proof. intros. destruct* m. Qed.

Lemma sym1 : forall E A B m, R E m A B -> R E (flip m) B A.
  intros. induction H.
  - autos.
  - destruct m; apply* STB2.
  - destruct m; apply* STB1.
  - apply* SFun.
  - apply* SVarRefl.
  - apply* SVarBndFl.
  - apply SVarBnd with (T:=T); try rewrite <- m_flip_inv; auto.
  - apply* SAll. destruct m1; simpl. simpl in IHR. auto.
    simpl in IHR. auto. intros. apply H1 in H2. destruct m2; simpl;
    simpl in H2; auto.
Defined.

Corollary sym2 : forall E A B m, R E m A B <-> R E (flip m) B A.
destruct m; split; apply sym1.
Defined.

Corollary sym : forall E A B, R E Sub A B <-> R E Sup B A.
  intros. split; apply sym1.
Defined.

(** In parentheses are given the label of the corresponding
  lemma in the description of the POPLMark Challenge. *)
Lemma TopBtmMustEq1 : forall m T1 T2 E,
okt E -> wft E T2 -> R E m T1 (mode_to_sub (flip m)) -> R E m T1 T2.
Proof. introv OK WF H. remember (mode_to_sub (flip m)) as T'.
  induction H; try destruct m; inversion* HeqT'.
  - subst. eapply SVarBnd. apply H. auto. auto.
  - subst. eapply SVarBnd. apply H. auto. auto.
  - destruct m2; inversion H3.  Qed.

Lemma TopBtmMustEq2 : forall m T1 T2 E,
okt E -> wft E T2 -> R E m (mode_to_sub m) T1  -> R E m T2 T1.
Proof. introv OK WF H. remember (mode_to_sub m) as T'.
  induction H; try destruct m; inversion* HeqT'.
  - subst. eapply SVarBndFl. apply H. auto. apply TopBtmMustEq1 with (T2:=T2) in H1; auto.
  - subst. eapply SVarBndFl. apply H. auto. apply TopBtmMustEq1 with (T2:=T2) in H1; auto.
  - destruct m2; inversion H3.  Qed.

Hint Resolve TopBtmMustEq1 TopBtmMustEq2.

(* ********************************************************************** *)
(** Narrowing and Transitivity (3) *)

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

Hint Unfold transitivity_on.

Hint Resolve wft_narrow.

Lemma sub_narrowing_aux : forall m1 m2 Q F E Z P S T,
  transitivity_on Q ->
  R (E & Z !:m1 <>: Q & F) m2 S T ->
  R E m1 P Q ->
  R (E & Z !:m1 <>: P & F) m2 S T.
Proof.
  introv TransQ SsubT PsubQ.
  inductions SsubT; introv.
  apply* SInt. apply* STB1. apply* STB2. apply* SFun. apply* SVarRefl.
  tests EQ: (X = Z).
    lets M: (@okt_narrow m1 Q).
    apply SVarBnd with (T:=P).
      asserts~ N: (ok (E & Z !:m1 <>: P & F)).
       lets: ok_middle_inv_r N.
        assert (m = m1). {
        apply binds_middle_eq_inv in H. inversion* H. auto. }
       subst;  apply* binds_middle_eq.
       replace E with (E&empty) in PsubQ; try apply concat_empty_r.
        apply sub_weakening with (F:=Z!:m1<>:P&F) in PsubQ.
        rewrite concat_empty_r in PsubQ. rewrite concat_assoc in PsubQ.
         apply sub_wft in PsubQ. destruct* PsubQ. rewrite concat_empty_r.
         rewrite concat_assoc. apply* M. rewrite concat_empty_r in PsubQ.
        apply sub_wft in PsubQ. destruct* PsubQ.
      apply TransQ.
      assert (m = m1). {
        apply binds_middle_eq_inv in H. inversion* H. auto. }
        subst.
        do_rew* concat_assoc (apply_empty* sub_weakening).
        binds_get H. inversion H1. subst. autos*.
    apply SVarBnd with (T:=T); auto. binds_cases H; auto.
  apply* wft_narrow. autos*.
    tests EQ: (X = Z).
    lets M: (@okt_narrow m1 Q).
    apply SVarBndFl with (T:=P).
      asserts~ N: (ok (E & Z !:m1 <>: P & F)).
       lets: ok_middle_inv_r N.
        assert (m = m1). {
        apply binds_middle_eq_inv in H. inversion* H. auto. }
       subst;  apply* binds_middle_eq.
       replace E with (E&empty) in PsubQ; try apply concat_empty_r.
        apply sub_weakening with (F:=Z!:m1<>:P&F) in PsubQ.
        rewrite concat_empty_r in PsubQ. rewrite concat_assoc in PsubQ.
         apply sub_wft in PsubQ. destruct* PsubQ. rewrite concat_empty_r.
         rewrite concat_assoc. apply* M. rewrite concat_empty_r in PsubQ.
        apply sub_wft in PsubQ. destruct* PsubQ.
      apply TransQ.
      assert (m = m1). {
        apply binds_middle_eq_inv in H. inversion* H. auto. }
        subst.
        do_rew* concat_assoc (apply_empty* sub_weakening).
        binds_get H. inversion H1. subst. autos*.
    apply SVarBndFl with (T:=T); auto. binds_cases H; auto.
  apply* wft_narrow. autos*.
  apply SAll with (L:=L). apply IHSsubT with (Q0:=Q); autos*.
  intros.
  apply H0 with (E0:=E) (Z0:=Z) (m3:=m1) (Q0:=Q) (F0:= (F & X !: m0 <>: SelectBound m2 T1 T2)) in H1; auto.
  rewrite concat_assoc in H1. auto. rewrite concat_assoc. auto.
Qed.

Lemma Var_Trans : forall E m T1 T2 X,
R E m T1 (typ_fvar X) -> R E m (typ_fvar X) T2 ->
  R E m T1 T2.
Proof. introv H1 H2. gen T2. inductions H1.
- destruct m; inversion x.
- introv Hy. apply* STB2.
- autos.
- introv Hy. eapply SVarBnd. apply H.
  autos. apply IHR with (X0:=X). autos. auto.
- introv Hy. apply sym2 in Hy. inductions Hy.
  + destruct m; inversion x.
  + apply* STB1.
  + eapply SVarBndFl. apply H. auto. auto.
  + eapply SVarBndFl. apply H3. auto. apply sym2.
    apply IHHy with (X0:=X); autos.
  + apply binds_get in H3. apply binds_get in H.
    rewrite H3 in H. inversion H. destruct m; inversion H5.
Qed.

Lemma sub_trans : forall Q,
  transitivity_on Q.
Proof.
  intro Q. introv SsubQ QsubT. asserts* W: (type Q).
  gen E S T. set_eq Q' EQ: Q. gen Q' EQ.
  induction W; intros Q' EQ E S SsubQ;
    induction SsubQ; try discriminate; inversions EQ;
      intros Ty QsubTy; inversions keep QsubTy;
        eauto 4.
    - destruct m; inversion H2. eapply SVarBnd.
    apply H. auto. apply TopBtmMustEq1; auto.
    - destruct m0; simpls.
      + eapply SVarBnd. apply H. auto.
        apply TopBtmMustEq1; auto.
      + apply sym2. eapply SVarBnd. simpl. apply H2. auto.
        apply TopBtmMustEq1; auto. eapply wft_var. apply H.
    - eapply SVarBnd. apply H. auto. auto.
    - destruct m; inversion H2.
    - eapply SVarBnd. apply H. auto. apply IHSsubQ; auto.
    - destruct m; inversion H2. eapply SVarBnd.
    apply H. auto. apply TopBtmMustEq1; auto.
   - destruct m0; simpls.
      + apply sym2. eapply SVarBnd. simpl. apply H2. auto.
        apply TopBtmMustEq1; auto. eapply wft_var. apply H.
      + eapply SVarBnd. apply H. auto.
        apply TopBtmMustEq1; auto.
    - destruct m; inversion H2.
    - eapply SVarBnd. apply H. auto. auto.
    - eapply SVarBnd. apply H. auto. apply IHSsubQ.
      auto. eapply SVarBnd. apply H3. auto. auto.
    - eapply SVarBnd. apply H. auto. apply IHSsubQ. auto. auto.
    - destruct m; inversion H1.
    - eapply SVarBndFl. apply H. auto. auto.
    - apply binds_get in H. apply binds_get in H2. rewrite H2 in H. inversion H.
      destruct m; inversion H4.
    - apply sym1 in H5. assert (m = m0). { destruct m; destruct m0; auto. }
      subst. eapply SVarBndFl. apply H2. auto. eapply Var_Trans.
      apply sym2. apply H5. eapply SVarBnd. apply H. auto. auto.
    - destruct m; inversion H.
    - apply SFun. apply sym1. apply IHW1 with (Q':=T1).
      auto. apply sym2. auto. apply sym2. auto.
      apply IHW2 with (Q':=T2). auto. auto. auto.
    - assert (forall T', R E m0 T T' -> R E m0 (typ_fvar X) T').
      { intros. eapply SVarBnd. apply H. auto. auto. }
       clear H. clear IHSsubQ2. clear IHSsubQ1. clear QsubTy.
       inductions H1.
      + destruct m; inversion x.
      + subst. apply sym1. apply TopBtmMustEq1. auto. auto. eapply H2.
       auto.
      + subst. apply sym1. apply H2. apply SFun.
        apply IHW1 with (Q':=T1). auto. auto.  apply sym2. auto.
        apply sym2. apply IHW2 with (Q':=T2). auto. auto.
        apply sym1. auto.
      + eapply IHR. auto. apply W2. auto. auto. apply W1.
        auto. auto. auto. intros. apply H3. eapply SVarBnd.  apply H. auto.
        auto.
    - destruct m; inversion H2.
    - assert (forall T', R E m T T' -> R E m (typ_fvar X) T').
      { intros. eapply SVarBnd. apply H. auto. auto. }
       clear H. clear IHSsubQ. clear H1. inductions SsubQ.
      + destruct m; inversion x.
      + apply H2. auto.
      + apply H2. apply SFun. apply sym1.
       apply IHW1 with (Q':=T1). auto. apply sym2. auto. apply sym2. auto.
       apply IHW2 with (Q':=T2). auto. auto. auto.
      + eapply IHSsubQ. auto. apply W2. auto. apply W1. auto.
        auto. auto. auto. auto. intros.  apply H2. eapply SVarBnd.
        apply H. auto. auto.
    - eapply SVarBnd. apply H. auto. eapply SVarBndFl.
      apply H2. auto. apply sym2. apply IHSsubQ; auto. apply sym1.
      auto.
    - destruct m; inversion H4.
    - eapply SVarBnd. apply H1. auto. eapply SVarBndFl. apply H4.
      auto. apply sym2. apply IHSsubQ; auto. apply sym1. auto.
    - assert (forall T', R E m T T' -> R E m (typ_fvar X) T').
      { intros. eapply SVarBnd. apply H1. auto. auto. } clear H1.
      clear H3. inductions SsubQ.
      + destruct m; inversion x.
      + apply H4. auto.
      + apply H4. apply IHSsubQ; auto.
      + apply H4. apply IHSsubQ; auto.
    - apply STB1. auto. apply wft_all with (L:=L0). auto.
      intros. destruct m2; simpls.
      + apply_empty wft_narrow. assert (wft (E & X !: m0 <>: T1) (T4 open_tt_var X)).
        { apply H1 in H5. autos. } apply H6.
       apply ok_from_okt. replace (E & X !: m0 <>: T0) with (E & X !: m0 <>: T0 & empty).
        apply okt_narrow with (V:=T1). rewrite concat_empty_r. apply H1 in H5. auto.
        auto. rewrite concat_empty_r. auto.
      + apply H1 in H5. autos.
    - destruct m2; inversion H3.
    - assert (forall T', R E m T T' -> R E m (typ_fvar X) T').
      { intros. eapply SVarBnd. apply H3. auto. auto. } clear H3.
      clear IHSsubQ. clear H2. inductions H5.
      + destruct m; inversion x.
      + apply sym1. apply H6. apply STB2. auto. apply wft_all with (L:= L \u L0).
        auto. intros. assert (R (E & X0 !: m0 <>: SelectBound (flip m) T0 T1)
       (flip m) (T4 open_tt_var X0) (T2 open_tt_var X0)).
      { apply H1. auto. } destruct m; simpls.
        * auto.
        * replace (E & X0 !: m0 <>: T0) with (E & X0 !: m0 <>: T0 & empty).
          apply wft_narrow with (V:=T1). rewrite concat_empty_r.
          autos. apply ok_from_okt. apply okt_narrow with (V:=T1).
          rewrite concat_empty_r. auto. auto. rewrite concat_empty_r. auto.
      + eapply IHR. auto. apply H. auto. apply W.
        auto. auto. auto. auto. auto. auto. auto. intros. apply H6.
        eapply SVarBnd. apply H3. auto. auto.
      + apply sym1. apply H6. apply SAll with (L:=L \u L0 \u L1).
        * destruct m0; simpls.
          { apply IHW with (Q':=T1). auto. auto. apply sym2. auto. }
          { apply sym2. apply IHW with (Q':=T1). auto. auto. apply sym1. auto. }
        * simpls. clear H2. clear IHR. intros. apply sym2.
          eapply H0 with (X := X0); autos. destruct m2; simpls.
        { apply H1. autos. }
        { apply_empty (@sub_narrowing_aux m0 Sub T1). unfold transitivity_on.
          intros. destruct m. apply IHW with (Q':=T1).
          auto. auto. auto. apply sym2. apply IHW with (Q':=T1).
          auto. apply sym2. auto. apply sym2. auto. apply H1. auto.
          destruct m0; auto.  }
        destruct m2; simpls.
        { apply_empty (@sub_narrowing_aux m0 Sup T1). unfold transitivity_on.
          intros. destruct m. apply sym2. apply IHW with (Q':=T1).
          auto. apply sym2. auto. apply sym2. auto. apply IHW with (Q':=T1).
          auto. auto. auto. apply sym2. apply H3. auto.
          destruct m0; auto.  }
        { apply sym2. apply H3. auto. }
    - apply SAll with (L:=L \u L0 \u L1).
         * destruct m0; simpls.
          { apply sym1. apply IHW with (Q':=T1). auto. apply sym2. auto. apply sym2. auto. }
          { apply IHW with (Q':=T1). auto. auto. auto. }
        * destruct m2; simpls; intros.
          { apply H0 with (X:=X) (Q':=T2 open_tt_var X). auto.
            auto. replace (E & X !: m0 <>: T5) with (E & X !: m0 <>: T5 & empty).
          apply (@sub_narrowing_aux m0 Sub T1). unfold transitivity_on.
          intros. destruct m.  apply IHW with (Q':=T1). auto.
          auto. auto. auto. apply sym2.  apply IHW with (Q':=T1). auto.
          apply sym2. auto. apply sym2. auto. rewrite concat_empty_r.
          auto. destruct m0; auto. simpl in H9. apply sym2. auto.
          simpl in H9. apply sym2. auto. rewrite concat_empty_r. auto.
          apply H10. auto.   }
          { apply H0 with (X:=X) (Q':=T2 open_tt_var X). auto.
            auto. auto.
          replace (E & X !: m0 <>: T0) with (E & X !: m0 <>: T0 & empty).
           apply (@sub_narrowing_aux m0 Sup T1). unfold transitivity_on.
          intros. destruct m. apply sym2.  apply IHW with (Q':=T1). auto.
          apply sym2. auto. apply sym2. auto. apply IHW with (Q':=T1). auto.
          auto. auto. rewrite concat_empty_r.
          auto. destruct m0; auto.  rewrite concat_empty_r. auto.
            }
Qed.

Lemma sub_narrowing : forall Q E m m' F Z P S T,
  R E m' P Q ->
  R (E & Z !: m' <>: Q & F) m S T ->
  R (E & Z !: m' <>: P & F) m S T.
Proof.
  intros.
  apply* sub_narrowing_aux.
  apply* sub_trans.
Qed.

Lemma sub_transitivity : forall Q E S m T,
  R E m S Q -> R E m Q T -> R E m S T.
Proof. intros.
assert (transitivity_on Q).
{ apply sub_trans. }
apply H1; autos. Qed.

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

Lemma okt_notin : forall E F X v,
okt(E&X~v&F) -> X # E.
Proof. induction F using env_ind; introv OK.
- rewrite concat_empty_r in OK. destruct v. apply okt_push_tvr_inv in OK.
destruct* OK.  apply okt_push_typ_inv in OK. destruct* OK.
- rewrite concat_assoc in OK. destruct v. apply okt_push_tvr_inv in OK.
destruct* OK.  apply okt_push_typ_inv in OK. destruct* OK. Qed.

Lemma sub_through_subst_tt : forall m1 m2 Q E F Z S T P,
  R (E & Z !: m1 <>: Q & F) m2 S T ->
  R E m1 P Q ->
  R (E & map (subst_tb Z P) F) m2 (subst_tt Z P S) (subst_tt Z P T).
Proof.
  introv SsubT PsubQ.
  inductions SsubT; introv; simpl subst_tt.
  apply* SInt.
  destruct m; apply* STB1.
  destruct m; apply* STB2.
  autos*.
  case_var.
    apply* refl.
    apply* SVarRefl.
    inversions H0. binds_cases H3.
      apply* wft_var.
      apply wft_var with (m:=m0) (T1:=subst_tt Z P T1). unsimpl_map_bind*.
      case_var.
      apply binds_middle_eq_inv in H. inversion H. subst.
     apply sub_transitivity with (Q:=Q). apply_empty* sub_weakening.
    rewrite* <- (@subst_tt_fresh Z P Q).
    apply (@notin_fv_wf E).
    apply sub_wft in PsubQ. destruct* PsubQ.
    apply sub_regular in SsubT. destruct SsubT. eapply okt_notin. apply H1.
    apply ok_from_okt. apply sub_regular in SsubT. destruct* SsubT.
    apply SVarBnd with (T:=(subst_tt Z P T)). rewrite* (@map_subst_tb_id E Z P).
    binds_cases H; unsimpl_map_bind*.
     apply sub_regular in PsubQ. destruct* PsubQ.
    apply* IHSsubT.
    case_var.
    apply binds_middle_eq_inv in H; auto. inversion H. subst.
    assert ( R (E & map (subst_tb Z P) F) m1 (subst_tt Z P Q) (subst_tt Z P F0)).
    {  autos*. } apply sym1. apply sub_transitivity with (Q:=(subst_tt Z P Q)); auto.
    rewrite*  (@subst_tt_fresh Z P Q). apply_empty sub_weakening; auto.
    apply (@notin_fv_wf E); auto. apply sub_regular in SsubT. destruct SsubT.
    apply okt_notin with (E:=E) (v:=(bind_tRel m1 Q)) (F:=F); auto.
    apply SVarBndFl with (T:=(subst_tt Z P T)). rewrite* (@map_subst_tb_id E Z P).
    binds_cases H; unsimpl_map_bind*.  apply* wft_subst_tb.
    apply* IHSsubT.
  apply SAll with (L:=L \u \{Z}). apply* IHSsubT.
  lets M:PsubQ. apply sub_wft in PsubQ. destruct* PsubQ.
  destruct m2; simpl; simpl in H0.
   unsimpl (subst_tb Z P (bind_tRel m0 T2)).
   intros. rewrite <- concat_assoc. rewrite <- map_push.
  rewrite* subst_tt_open_tt_var. rewrite* subst_tt_open_tt_var.
   apply H0 with (m2:=m1) (Q0:=Q); autos. rewrite concat_assoc. auto.
 unsimpl (subst_tb Z P (bind_tRel m0 T1)).
   intros. rewrite <- concat_assoc. rewrite <- map_push.
  rewrite* subst_tt_open_tt_var. rewrite* subst_tt_open_tt_var.
   apply H0 with (m2:=m1) (Q0:=Q); autos. rewrite concat_assoc. auto.
Qed.

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

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

Lemma typing_weakening : forall E F G e T,
   typing (E & G) e T ->
   okt (E & F & G) ->
   typing (E & F & G) e T.
Proof.
  introv Typ. gen F. inductions Typ; introv Ok.
  apply* typing_var. apply* binds_weaken.
  apply_fresh* typing_abs as x. forwards~ K: (H x).
   apply_ih_bind (H0 x); eauto.
  apply* typing_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 m x U E F S T,
  R (E & x ~: U & F) m S T ->
  R (E & F) m S T.
Proof.
  intros m x U E F S T SsubT.
  inductions SsubT; introv; autos* wft_strengthen.
  (* case: fvar trans *)
  apply SVarBnd with (T:=T); autos*. binds_cases H; autos*.
  apply SVarBndFl with (T:=T); autos*. binds_cases H; autos*.
  (* case: all *)
  apply SAll with (L:= L); autos*. intros. apply_ih_bind* H0.
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. inductions TypT; introv; 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.
  lets M:TypU. apply typing_regular in M. destruct M. auto.
  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. apply* wft_strengthen.
Qed.

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

Lemma typing_through_subst_te : forall E F Z m Ty e T P,
  typing (E & Z!: m <>: Ty & F) e T ->
  R E m P Ty ->
  typing (E & map (subst_tb Z P) F) (subst_te Z P e) (subst_tt Z P T).
Proof.
  introv Typ WFT.
  inductions Typ; simpls subst_tt; simpls subst_te; autos*.
  subst. apply* typing_var. rewrite* (@map_subst_tb_id E Z P).
  binds_cases H0; unsimpl_map_bind*.
  (* case abs *)
  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.
  (* case tabs *)
  apply_fresh* typing_tabs as Y.
   unsimpl (subst_tb Z P (bind_tRel m0 Tk)).
    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, R E Sub T (typ_arrow U1 U2) ->
     R E Sub U1 S1
  /\ exists S2, exists L, forall x, x \notin L ->
     typing (E & x ~: S1) (e1 open_ee_var x) S2 /\ R E Sup U2 S2).
Proof.
  introv Typ. gen_eq e: (trm_abs S1 e1). gen S1 e1.
  induction Typ; intros S1 b1 EQ U1 U2 R; inversions EQ.
  inversions* R. split.
  rewrite <- sym2 in H6. auto.
  exists T1. exists L. split; autos.
  rewrite sym2. apply H8.
  apply IHTyp. autos. eapply sub_transitivity.
  apply H. apply R.
Qed.

Lemma typing_inv_tabs : forall E e T m0 T0,
  typing E (trm_tabs m0 T0 e) T ->
  forall U m T', R E Sub T (typ_all m T' U) ->
  exists S, exists L, forall X, X \notin L ->
     typing (E & X!:m <>: T0) (e open_te_var X) (S open_tt_var X)
     /\ R (E & X!:m <>: T') Sub (S open_tt_var X) (U open_tt_var X)
     /\ m = m0
     /\ R E (BindPosVariance Sub m) T0 T'.
Proof.
  introv Ty Sub. remember (trm_tabs m0 T0 e) as trm.
  remember (typ_all m T' U) as ty.
  induction Ty; inversion Heqtrm; subst; clear H0.
  - exists T. inversion Sub. subst. exists (L \u L0).
    introv NI. apply notin_union_r in NI. destruct NI. split.
    apply* H. split; auto.
  - apply* IHTy. eapply sub_transitivity. apply H. auto.
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 refl with (E:=E). apply typing_regular in Typ1. destruct Typ1.
    destruct H0. auto. auto.
    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* sym2.
      apply_empty sub_weakening. auto. auto.
       inversion Typ1. subst. apply Typ2. subst. eapply typing_sub. apply Typ2. auto.
       auto.
  (* case: tapp *)
  -inversions Red; try solve [ apply* typing_tapp ].
   destruct (typing_inv_tabs Typ (U:=T1) (m:=m) (T':=Tb)).
    apply* refl.
   apply typing_regular in Typ. destruct Typ.
    destruct H3.  inversion H5; subst. destruct H0.
    pick_fresh X. forwards~ K : ( H0 X). destruct K.
   rewrite* (@subst_te_intro X). rewrite* (@subst_tt_intro X).
   replace E with (E & map (subst_tb X T2) empty).
   replace (E & X!: m <>: T) with (E & X!: m <>: T & empty) in H6.
    eapply typing_sub.
   apply (typing_through_subst_te H6).
    eapply sub_transitivity. apply H. destruct H7.
    destruct H8. apply sym2. auto.
   apply* (@sub_through_subst_tt m Sub Tb E empty X).
    destruct H7. rewrite concat_empty_r. auto.
   apply* wft_subst_tb.
   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 (R empty Sub T (typ_arrow U1 U2)).
{ rewrite st.
    apply refl 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 (R E0 Sub S (typ_arrow U1 U2)). {
    eapply sub_transitivity. apply H. apply EQT. }
   eapply IHTyp. apply Val. apply H1. reflexivity. Qed.

Lemma tall_inv : forall E m m1 m2 T1 T2 M N,
R E m (typ_all m1 T1 M) (typ_all m2 T2 N) -> m1=m2 /\
R E (BindPosVariance m2 m) T1 T2.
Proof. introv TA. inductions TA.
- destruct m; inversion x.
- destruct m; inversion x.
- split; auto. Qed.

Lemma canonical_form_tabs : forall t T m U,
  value t -> typing empty t (typ_all m T U) ->
  exists T' e1, t = trm_tabs m T' e1 /\ R empty (BindPosVariance m Sub) T' T.
Proof.
  introv Val Typ.
  gen_eq Ty: (typ_all m T U). intro st.
  assert (R empty Sub Ty (typ_all m T U)). { rewrite* st.
  apply refl 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 ].
  apply tall_inv in H.
  exists Tk. exists e. split. destruct H. subst. auto.
  destruct H. auto.
  apply* IHTyp. eapply sub_transitivity.
  apply H0. auto. Qed.

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

Lemma progress_result : progress.
Proof.
  introv Typ. gen_eq E: (@empty typ). lets Typ': Typ. remember empty as Env.
  induction Typ; intros EQ; subst.
  left*.
  (* 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).
  left*.
  right. destruct* IHTyp as [Val | [e1 Red]].
      destruct (canonical_form_tabs Val Typ).
        subst. destruct H0. destruct H0. subst. exists* (open_te x0 T2).
  autos*.
Qed.


Module TPSmallSteps.

Require Import String.
Open Scope string_scope.

Load TPSyntax.
Export TPSyntax.

Open Scope Z_scope.

Definition TPEvalOp op n1 n2 :=
  match op,  n1, n2 with
    | TPOperatorPlus,     TPExpConst (TPConstantInt n), TPExpConst (TPConstantInt n') => TPInt (n + n')
    | TPOperatorMinus,    TPExpConst (TPConstantInt n), TPExpConst (TPConstantInt n') => TPInt (n - n')
    | TPOperatorMult,     TPExpConst (TPConstantInt n), TPExpConst (TPConstantInt n') => TPInt (n * n')
    | TPOperatorDiv,      TPExpConst (TPConstantInt n), TPExpConst (TPConstantInt n') => TPInt (n / n')
    | TPOperatorMod,      TPExpConst (TPConstantInt n), TPExpConst (TPConstantInt n') => TPInt (n mod n')
    | TPOperatorLess,     TPExpConst (TPConstantInt n), TPExpConst (TPConstantInt n') => TPBool (Zlt_bool n n')
    | TPOperatorLessEq,   TPExpConst (TPConstantInt n), TPExpConst (TPConstantInt n') => TPBool (Zle_bool n n')
    | TPOperatorGreater,  TPExpConst (TPConstantInt n), TPExpConst (TPConstantInt n') => TPBool (Zgt_bool n n')
    | TPOperatorGreaterEq,TPExpConst (TPConstantInt n), TPExpConst (TPConstantInt n') => TPBool (Zge_bool n n')
    | TPOperatorEq,       TPExpConst (TPConstantInt n), TPExpConst (TPConstantInt n') => TPBool (Zeq_bool n n')
    | TPOperatorNeq,      TPExpConst (TPConstantInt n), TPExpConst (TPConstantInt n') => TPBool (Zneq_bool n n')
    | _, _, _ => TPHang
  end.

Fixpoint TPFreeVars exp :=
  match exp with
    | TPExpConst _ => nil
    | TPExpId id => id :: nil
    | TPExpApp exp1 exp2 => app (TPFreeVars exp1) (TPFreeVars exp2)
    | TPExpIf exp1 exp2 exp3 => app (TPFreeVars exp1) (app (TPFreeVars exp2) (TPFreeVars exp3))
    | TPExpAbstr id exp => filter (ident_eq id) (TPFreeVars exp)
    | TPExpLet id e1 e2 => app (filter (ident_eq id) (TPFreeVars e2)) (TPFreeVars e1)
    | TPExpRec id exp => filter (ident_eq id) (TPFreeVars exp)
  end.

Definition new_id highest_id id := (TPId (id, S highest_id), S highest_id).

(* Substitute id in e by e', using notation from lecture: e[e'/id] *)
Fixpoint TPSubst (highest_id : nat) e e' id : TPExp * nat :=
  match e with
    | TPExpConst c => (e, highest_id)
    | TPExpId id' =>
      if ident_eq id' id
        then (e', highest_id)
        else (TPExpId id', highest_id)
    | TPExpIf e1 e2 e3 =>
      let (e1', n1) := TPSubst highest_id e1 e' id in
        let (e2', n2) := TPSubst n1 e2 e' id in
          let (e3', n3) := TPSubst n2 e3 e' id in
            (TPIf e1' e2' e3', n3)
    | TPExpApp e1 e2 =>
      let (e1', n1) := TPSubst highest_id e1 e' id in
        let (e2', n2) := TPSubst n1 e2 e' id in
         (TPExpApp e1' e2', n2)
    | TPExpAbstr id' e =>
      if ident_eq id' id
        then (e, highest_id)
        else let (e1, n) := TPSubst highest_id e e' id in (TPExpAbstr id' e1, n)
    | TPExpLet id' e1 e2 =>
      let (e1', n1) := TPSubst highest_id e1 e' id in
        let (e2', n2) := TPSubst n1 e2 e' id in
          (TPExpLet id' e1' (if ident_eq id' id then e2 else e2'), n2)
    | TPExpRec id' e =>
      if ident_eq id' id
        then (e, highest_id)
        else let (e'', n) := TPSubst highest_id e e' id in (TPExpRec id' e'', n)
  end.

(* TODO Figure out, whether this definition is correct. *)
Inductive TPMakesSmallstep: nat -> TPExp -> TPExp * nat -> Prop :=
| smallstep_op: forall idx n1 n2 op,
  TPMakesSmallstep idx (TPApp (TPApp (TPOp op) (TPInt n1)) (TPInt n2)) (TPEvalOp op (TPInt n1) (TPInt n2), idx)
| smallstep_betav: forall idx id exp v,
  TPIsValue v -> TPMakesSmallstep idx (TPApp (TPAbstr id exp) v) (TPSubst idx exp v id)
| smallstep_appleft: forall idx idx' exp1 exp1' exp2,
  TPMakesSmallstep idx exp1 (exp1', idx') -> TPMakesSmallstep idx (TPApp exp1 exp2) (TPApp exp1' exp2, idx')
| smallstep_appright: forall idx idx' exp exp' v,
  TPIsValue v -> TPMakesSmallstep idx exp (exp', idx') -> TPMakesSmallstep idx' (TPApp v exp) (TPApp v exp', idx')
| smallstep_condeval: forall idx idx' exp0 exp0' exp1 exp2,
  TPMakesSmallstep idx exp0 (exp0', idx') -> TPMakesSmallstep idx' (TPIf exp0 exp1 exp2) (TPIf exp0' exp1 exp2, idx')
| smallstep_condtrue: forall idx exp1 exp2,
  TPMakesSmallstep idx (TPIf TPTrue exp1 exp2) (exp1, idx)
| smallstep_condfalse: forall idx exp1 exp2,
  TPMakesSmallstep idx (TPIf TPFalse exp1 exp2) (exp2, idx)
| smallstep_leteval: forall idx idx' id exp1 exp1' exp2,
  TPMakesSmallstep idx exp1 (exp1', idx') -> TPMakesSmallstep idx' (TPLet id exp1 exp2) (TPLet id exp1' exp2, idx')
| smallstep_letexec: forall idx id exp v,
  TPIsValue v -> TPMakesSmallstep idx (TPLet id v exp) (TPSubst idx exp v id)
| smallstep_unfold: forall idx id exp,
  TPMakesSmallstep idx (TPRec id exp) (TPSubst idx exp (TPRec id exp) id).

Fixpoint smallstep (n : nat) (exp : TPExp) : TPExp * nat :=
  match exp with
    | TPExpApp (TPExpApp (TPExpConst (TPConstantOp op)) (TPExpConst (TPConstantInt n1))) (TPExpConst (TPConstantInt n2)) =>
      (TPEvalOp op (TPInt n1) (TPInt n2), n)                                  (* OP *)
    | TPExpApp (TPExpAbstr id e1) e2 =>
      if TPIsValue_bool e2
        then TPSubst n e1 e2 id                                               (* BETA-V *)
        else let (e', n') := smallstep n e2 in (TPApp (TPAbstr id e1) e', n') (* APP-RIGHT *)
    | TPExpApp e1 e2 =>
      if TPIsValue_bool e1
        then let (e', n') := smallstep n e2 in (TPApp e1 e', n')              (* APP-LEFT *)
        else let (e', n') := smallstep n e1 in (TPApp e' e2, n')              (* APP-RIGHT *)
    | TPExpIf e1 e2 e3 =>
      if TPIsValue_bool e1
        then if TPExp_eq e1 TPTrue
          then (e2, n)                                                        (* COND-TRUE *)
          else (e3, n)                                                        (* COND-FALSE *)
        else let (e', n') := smallstep n e1 in (TPIf e' e2 e3, n')            (* COND-EVAL *)
    | TPExpLet id e1 e2 =>
      if TPIsValue_bool e1
        then TPSubst n e2 e1 id                                               (* LET-EXEC *)
        else let (e', n') := smallstep n e1 in (TPLet id e' e2, n')           (* LET-EVAL *)
    | TPExpRec id e => TPSubst n e (TPRec id e) id                            (* UNFOLD *)
  (* Otherwise, no small step exists and the execution hangs *)
    | _ => (TPHang, n)
  end.

Inductive NonEmptyList (A: Type) :=
| Singleton: A -> NonEmptyList A
| Cons: A -> NonEmptyList A -> NonEmptyList A.

Implicit Arguments Singleton [A].
Implicit Arguments Cons [A].

Definition first {A: Type}(l: NonEmptyList A) := match l with
| Singleton a => a
| Cons a l' => a
end.

Fixpoint last {A: Type}(l: NonEmptyList A) := match l with
| Singleton a => a
| Cons a l' => (last l')
end.

Fixpoint length {A: Type}(l: NonEmptyList A) := match l with
| Singleton a => 1%nat
| Cons a l' => S (length l')
end.

Fixpoint nth_default {A: Type}(def: A)(n: nat)(l: NonEmptyList A) := match n,l with
| O, l => first l
| S n', Cons a l' => nth_default def n' l'
| S n', Singleton a => def
end.

Definition TPMultipleSmallsteps exp exp':=
exists steps: NonEmptyList TPExp,
first steps = exp ->
last steps = exp' ->
forall idx n, (n < ((length steps)-1))%nat -> TPMakesSmallstep idx (nth_default TPExn n steps) (nth_default TPExn (n+1) steps, idx).

Definition step0 := (TPLet ("square", 0%nat) (TPAbstr ("x", 1%nat) (TPApp (TPApp TPMult (TPId ("x", 1%nat))) (TPId ("x",1%nat)))) (TPApp (TPId ("square", 0%nat))(TPApp (TPId ("square", 0%nat)) (TPInt 5)))).
Definition step1 := (TPApp (TPAbstr ("x", 1%nat) (TPApp (TPApp TPMult (TPId ("x", 1%nat))) (TPId ("x", 1%nat))))(TPApp (TPAbstr ("x", 1%nat) (TPApp (TPApp TPMult (TPId ("x", 1%nat))) (TPId ("x", 1%nat)))) (TPInt 5))).
Definition step2 := (TPApp (TPAbstr ("x", 1%nat) (TPApp (TPApp TPMult (TPId ("x", 1%nat))) (TPId ("x", 1%nat))))(TPApp (TPApp TPMult (TPInt 5)) (TPInt 5))).
Definition step3 := (TPApp (TPAbstr ("x", 1%nat) (TPApp (TPApp TPMult (TPId ("x", 1%nat))) (TPId ("x", 1%nat))))(TPInt 25)).
Definition step4 := (TPApp (TPApp TPMult (TPInt 25)) (TPInt 25)).
Definition step5 := TPInt 625.

Lemma less_nat_cases: forall k n: nat, (k < (S n) <-> k < n \/ k = n)%nat.
Proof.
  intros k n.
  split; intros H.
  (* => *)
    apply lt_n_Sm_le in H.
    case_eq (beq_nat k n); intros Heq.
      (* Case: true *)
      right. apply beq_nat_true_iff in Heq. exact Heq.
      (* Case: false *)
      left. apply beq_nat_false_iff in Heq.
      apply nat_total_order in Heq. destruct Heq as [Heq | Heq].
        (* Case: k < n *)
        exact Heq.
        (* Case: k > n *)
        apply le_lt_trans with (n:=k) in Heq.
          contradict Heq. apply lt_irrefl.
          exact H.
  (* <= *)
    destruct H as [H | H].
      apply lt_S. exact H.
      rewrite H. constructor.
Qed.

Example test1: TPMultipleSmallsteps step0 step5.
Proof.
  unfold TPMultipleSmallsteps.
  exists (Cons step0 (Cons step1 (Cons step2 (Cons step3 (Cons step4 (Singleton step5)))))).
  intros Hfirst Hlast n idx Hn.
  clear Hfirst. clear Hlast. simpl in Hn.

  repeat ((try (apply lt_n_Sm_le in Hn; apply le_n_0_eq in Hn; symmetry in Hn)) || (try (apply less_nat_cases in Hn; destruct Hn as [Hn | H])));
  try rename H into Hn; rewrite Hn; simpl; repeat constructor.
  apply smallstep_appright with (idx := n).
  now apply TPAbstrIsValue.
  assert (H : TPSubst n (TPApp (TPApp TPMult (TPId ("x", 1%nat))) (TPId ("x", 1%nat))) (TPInt 5) ("x", 1%nat) = (TPApp (TPApp TPMult (TPInt 5)) (TPInt 5), n)).
  simpl; unfold TPApp; unfold TPMult; now reflexivity.
  rewrite <- H.
  apply smallstep_betav.
  now apply TPConstIsValue.
  apply smallstep_appright with (idx := n).
  now apply TPAbstrIsValue.
  apply smallstep_op.
Qed.

Lemma smallstep_consist : forall n n' e e', smallstep n e = (e', n') <-> TPMakesSmallstep n e (e', n').
Proof.
  intros n n' e e'.
  induction e.
  unfold smallstep.
Admitted.

End TPSmallSteps.


Require Import Coq.omega.Omega.
Require Import Coq.Lists.ListSet.
Require Import Coq.Lists.List.
Require Import Node.

(** STATE STRUCTURE AND PARAMETERS *)

Inductive Status : Type :=
  | Stabilizing : Status
  | Rectifying : Status.

Inductive adjacent {A} : A -> A -> list A -> Prop :=
  | adj_hd : forall (j k : A) (l : list A),
               head l = Some j ->
               head (tl l) = Some k ->
               adjacent j k l
  | adj_tl : forall (j k : A) (l : list A),
               head l <> None ->
               adjacent j k (tl l) ->
               adjacent j k l.

(* NetState *)
Record NetState : Type := mkNetState
  {
    members: set Node;
    succlength : nat;
    succ : Node -> list Node;
    prdc : Node -> Node;
    status : Node -> Status
  }.

(* Invariant *)
Definition WellFormedNetState (s : NetState) : Prop :=
  NoDup (members s) /\
  succlength s > 0 /\
  forall (n : Node), set_In n (members s) -> length (succ s n) = succlength s.

Definition LiveSuccCondition (s : NetState) : Prop :=
  forall (n : Node), set_In n (members s) ->
    Exists (fun m => set_In m (members s)) (succ s n).

Definition Principal (s : NetState) (p : Node) : Prop :=
  forall n, set_In n (members s) ->
    forall j k : Node, adjacent j k (n :: (succ s n)) ->
    ~ (between j p k).

Definition SufficientPrincipals (s : NetState) : Prop :=
  exists (principals : set Node),
    length principals >= succlength s + 1 /\
    NoDup principals /\
    (forall (p : Node), set_In p principals ->
      set_In p (members s) /\
      Principal s p).

Definition Invariant (s : NetState) : Prop :=
  WellFormedNetState s /\ LiveSuccCondition s /\ SufficientPrincipals s.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2018   --   Inria - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require int.Abs.

Require Import Zquot.

(* Why3 comment *)
(* div is replaced with (ZArith.BinInt.Z.quot x x1) by the coq driver *)

(* Why3 comment *)
(* mod1 is replaced with (ZArith.BinInt.Z.rem x x1) by the coq driver *)

(* Why3 goal *)
Lemma Div_mod :
forall (x:Z) (y:Z),
 (~ (y = 0%Z)) ->
 (x = ((y * (ZArith.BinInt.Z.quot x y))%Z + (ZArith.BinInt.Z.rem x y))%Z).
intros x y _.
apply Z.quot_rem'.
Qed.

(* Why3 goal *)
Lemma Div_bound :
forall (x:Z) (y:Z),
 ((0%Z <= x)%Z /\ (0%Z < y)%Z) ->
 ((0%Z <= (ZArith.BinInt.Z.quot x y))%Z
  /\ ((ZArith.BinInt.Z.quot x y) <= x)%Z).
intros x y (Hx,Hy).
split.
now apply Z.quot_pos.
destruct (Z_eq_dec y 1) as [H|H].
rewrite H, Z.quot_1_r.
apply Zle_refl.
destruct (Zle_lt_or_eq 0 x Hx) as [H'|H'].
apply Zlt_le_weak.
apply Z.quot_lt with (1 := H').
omega.
now rewrite <- H', Zquot_0_l.
Qed.

(* Why3 goal *)
Lemma Mod_bound :
forall (x:Z) (y:Z),
 (~ (y = 0%Z)) ->
 (((-(ZArith.BinInt.Z.abs y))%Z < (ZArith.BinInt.Z.rem x y))%Z
  /\ ((ZArith.BinInt.Z.rem x y) < (ZArith.BinInt.Z.abs y))%Z).
intros x y Zy.
destruct (Zle_or_lt 0 x) as [Hx|Hx].
refine ((fun H => conj (Zlt_le_trans _ 0 _ _ (proj1 H)) (proj2 H)) _).
clear -Zy ; zify ; omega.
now apply Zrem_lt_pos.
refine ((fun H => conj (proj1 H) (Zle_lt_trans _ 0 _ (proj2 H) _)) _).
clear -Zy ; zify ; omega.
apply Zrem_lt_neg with (2 := Zy).
now apply Zlt_le_weak.
Qed.

(* Why3 goal *)
Lemma Div_sign_pos :
forall (x:Z) (y:Z),
 ((0%Z <= x)%Z /\ (0%Z < y)%Z) -> (0%Z <= (ZArith.BinInt.Z.quot x y))%Z.
intros x y (Hx, Hy).
now apply Z.quot_pos.
Qed.

(* Why3 goal *)
Lemma Div_sign_neg :
forall (x:Z) (y:Z),
 ((x <= 0%Z)%Z /\ (0%Z < y)%Z) -> ((ZArith.BinInt.Z.quot x y) <= 0%Z)%Z.
intros x y (Hx, Hy).
generalize (Z.quot_pos (-x) y).
rewrite Zquot_opp_l.
omega.
Qed.

(* Why3 goal *)
Lemma Mod_sign_pos :
forall (x:Z) (y:Z),
 ((0%Z <= x)%Z /\ ~ (y = 0%Z)) -> (0%Z <= (ZArith.BinInt.Z.rem x y))%Z.
intros x y (Hx, Zy).
now apply Zrem_lt_pos.
Qed.

(* Why3 goal *)
Lemma Mod_sign_neg :
forall (x:Z) (y:Z),
 ((x <= 0%Z)%Z /\ ~ (y = 0%Z)) -> ((ZArith.BinInt.Z.rem x y) <= 0%Z)%Z.
intros x y (Hx, Zy).
now apply Zrem_lt_neg.
Qed.

(* Why3 goal *)
Lemma Rounds_toward_zero :
forall (x:Z) (y:Z),
 (~ (y = 0%Z)) ->
 ((ZArith.BinInt.Z.abs ((ZArith.BinInt.Z.quot x y) * y)%Z) <= (ZArith.BinInt.Z.abs x))%Z.
intros x y Zy.
rewrite Zmult_comm.
zify.
generalize (Z.mul_quot_le x y).
generalize (Z.mul_quot_ge x y).
omega.
Qed.

(* Why3 goal *)
Lemma Div_1 :
forall (x:Z), ((ZArith.BinInt.Z.quot x 1%Z) = x).
exact Z.quot_1_r.
Qed.

(* Why3 goal *)
Lemma Mod_1 :
forall (x:Z), ((ZArith.BinInt.Z.rem x 1%Z) = 0%Z).
exact Z.rem_1_r.
Qed.

(* Why3 goal *)
Lemma Div_inf :
forall (x:Z) (y:Z),
 ((0%Z <= x)%Z /\ (x < y)%Z) -> ((ZArith.BinInt.Z.quot x y) = 0%Z).
exact Z.quot_small.
Qed.

(* Why3 goal *)
Lemma Mod_inf :
forall (x:Z) (y:Z),
 ((0%Z <= x)%Z /\ (x < y)%Z) -> ((ZArith.BinInt.Z.rem x y) = x).
exact Z.rem_small.
Qed.

(* Why3 goal *)
Lemma Div_mult :
forall (x:Z) (y:Z) (z:Z),
 ((0%Z < x)%Z /\ ((0%Z <= y)%Z /\ (0%Z <= z)%Z)) ->
 ((ZArith.BinInt.Z.quot ((x * y)%Z + z)%Z x) = (y + (ZArith.BinInt.Z.quot z x))%Z).
intros x y z (Hx&Hy&Hz).
rewrite (Zplus_comm y).
rewrite <- Z_quot_plus.
now rewrite Zplus_comm, Zmult_comm.
apply Zmult_le_0_compat with (2 := Hz).
apply Zplus_le_0_compat with (1 := Hz).
apply Zmult_le_0_compat with (1 := Hy).
now apply Zlt_le_weak.
intros H.
now rewrite H in Hx.
Qed.

(* Why3 goal *)
Lemma Mod_mult :
forall (x:Z) (y:Z) (z:Z),
 ((0%Z < x)%Z /\ ((0%Z <= y)%Z /\ (0%Z <= z)%Z)) ->
 ((ZArith.BinInt.Z.rem ((x * y)%Z + z)%Z x) = (ZArith.BinInt.Z.rem z x)).
intros x y z (Hx&Hy&Hz).
rewrite Zplus_comm, Zmult_comm.
apply Z_rem_plus.
apply Zmult_le_0_compat with (2 := Hz).
apply Zplus_le_0_compat with (1 := Hz).
apply Zmult_le_0_compat with (1 := Hy).
now apply Zlt_le_weak.
Qed.


(** Credit to Jasper Hugunin (jashug) for this module.
 *
 * MIT license, (c) Jasper Hugunin
 * Link: https://github.com/jashug/IWTypes/blob/master/Adjointification.v
 *)

(* Turn a pair of inverses into an adjoint equivalence *)
(* Proof follows the HoTT book *)
(* Mostly, just a lot of manipulation of equality proofs *)

(* Lemma 2.4.3 in HoTT book, specialized to g = id *)
Definition commute_homotopy_id {A} {f : A -> A}
  (f_id : forall a, f a = a) {x y : A} (p : x = y)
  : eq_trans (f_id x) p = eq_trans (f_equal f p) (f_id y)
  := match p in (_ = y)
     return eq_trans (f_id x) p = eq_trans (f_equal f p) (f_id y)
     with eq_refl => eq_sym (eq_trans_refl_l (f_id x)) end.

Section adjointify.
Context {A B} (f : A -> B) (g : B -> A).

Section g_adjoint.
Context
  (gf_id : forall a, g (f a) = a)
  (fg_id : forall b, f (g b) = b).

Definition f_adjoint_gives_g_adjoint_pointwise
  (b : B) (f_adjoint_at_gb : fg_id (f (g b)) = f_equal f (gf_id (g b)))
  : gf_id (g b) = f_equal g (fg_id b)
  := let precomposed_eq
      : eq_trans (f_equal (fun a => g (f a)) (f_equal g (fg_id b)))
         (gf_id (g b)) =
        eq_trans (f_equal g (f_equal (fun b => f (g b)) (fg_id b)))
          (f_equal g (fg_id b))
      := eq_trans
         (eq_sym (commute_homotopy_id gf_id (f_equal g (fg_id b))))
         (eq_rect (f_equal g (fg_id (f (g b)))) (fun p => eq_trans p _ = _)
          (eq_trans (eq_trans
           (eq_sym (eq_trans_map_distr g _ _))
           (f_equal (fun p => f_equal g p)
            (commute_homotopy_id fg_id (fg_id b))))
           (eq_trans_map_distr g _ _)) _
          (eq_trans (eq_trans
           (f_equal (fun p => f_equal g p) f_adjoint_at_gb)
           (f_equal_compose f g _))
           (eq_id_comm_r _ gf_id  (g b)))) in
     match fg_id b as p
     return
       forall p1 p2,
       eq_trans (f_equal _ (f_equal g p)) p1 =
       eq_trans (f_equal g (f_equal _ p)) p2 ->
       p1 = p2
     with eq_refl => fun p1 p2 eq =>
       eq_trans (eq_trans
         (eq_sym (eq_trans_refl_l _))
         eq)
         (eq_trans_refl_l _)
     end (gf_id (g b)) (f_equal g (fg_id b)) precomposed_eq.

Definition f_adjoint_gives_g_adjoint
  (f_adjoint : forall a, fg_id (f a) = f_equal f (gf_id a))
  (b : B) : gf_id (g b) = f_equal g (fg_id b)
  := f_adjoint_gives_g_adjoint_pointwise b (f_adjoint (g b)).
End g_adjoint.

Section correction.
Context
  (gf_id : forall a, g (f a) = a)
  (fg_id : forall b, f (g b) = b).

(* N.B.: The adjoint equivalence will use this instead of the given section. *)
Definition fg_id' b : f (g b) = b
  := eq_trans (eq_sym (fg_id (f (g b))))
     (eq_trans (f_equal f (gf_id (g b))) (fg_id b)).

Definition f_adjoint a : fg_id' (f a) = f_equal f (gf_id a)
  := let symmetric_eq
      : eq_trans (f_equal f (gf_id (g (f a)))) (fg_id (f a)) =
        eq_trans (fg_id (f (g (f a)))) (f_equal f (gf_id a))
      := eq_trans (eq_trans
         (f_equal (fun H => eq_trans (f_equal f H) (fg_id (f a)))
          (eq_sym (eq_id_comm_r _ gf_id a)))
         (f_equal (fun p => eq_trans p _)
          (eq_trans
           (f_equal_compose (fun a => g (f a)) f _)
           (eq_sym (f_equal_compose f (fun b => f (g b)) _)))))
         (eq_sym (commute_homotopy_id fg_id (f_equal f (gf_id a)))) in
     match fg_id (f (g (f a))) as p
     return forall p', _ = eq_trans p p' -> eq_trans (eq_sym p) _ = p'
     with eq_refl => fun p' eq =>
       eq_trans (eq_trans_refl_l _) (eq_trans eq (eq_trans_refl_l _))
     end _ symmetric_eq.

Definition g_adjoint
  : forall b, gf_id (g b) = f_equal g (fg_id' b)
  := f_adjoint_gives_g_adjoint gf_id fg_id' f_adjoint.

End correction.

End adjointify.


From Equations Require Import Equations.
From Coq Require Import ssreflect ssrbool ssrfun.
From mathcomp Require Import ssrnat eqtype seq path order bigop.
From favssr Require Import prelude.

Import Order.POrderTheory.
Import Order.TotalTheory.
Open Scope order_scope.

Section Selection.
Context {disp : unit} {T : orderType disp}.
Implicit Types (xs ys zs: seq T) (k : nat).

Definition kthOrd k xs v :=
  k < size xs ->
  (size [seq x <- xs | x < v ] <= k) &&
  (size [seq x <- xs | x > v ] <  size xs - k).

Definition selection (select : nat -> seq T -> T) :=
  forall k xs, kthOrd k xs (select k xs).

Lemma subseq_consr (s1 s2 : seq T) a :
  subseq s1 s2 -> subseq s1 (a :: s2).
Proof.
rewrite -{2}[s1]/([::] ++ s1) -[a :: s2]/([::a] ++ s2).
by apply cat_subseq.
Qed.

Lemma subset_filter_impl xs (p q : pred T) :
  (forall x, p x -> q x) ->
  subseq [seq x <- xs | p x] [seq x <- xs | q x].
Proof.
elim: xs => // a xs IH pi /=.
move: (pi a).
case pa: (p a).
  move => -> //=.
  rewrite eq_refl.
  by apply (IH pi).
case qa: (q a) => _.
  apply subseq_consr. by apply (IH pi).
by apply (IH pi).
Qed.

Lemma filter_size_neg_pred p q xs :
  (forall a, p a = ~~ (q a)) ->
  size [seq x <- xs | p x] + size [seq x <- xs | q x ] = size xs.
Proof.
elim: xs => // a sx IH Hpq //=.
move: (Hpq a).
case (q a) => /= ->.
  by rewrite addnS IH.
by rewrite addSn IH.
Qed.

Lemma leq_le_add (a b x y: nat) : (a <= x -> b < y -> a + b < x + y)%N.
Proof.
move => /subnKC <-.
rewrite -addnA (ltn_add2l a) => b_le_y.
by rewrite ltn_addl.
Qed.

Lemma kthOrd_unique k xs x y :
  k < size xs ->
  kthOrd k xs x ->
  kthOrd k xs y ->
  x = y.
Proof.
case heq: (x == y); move: heq => /eqP; first done.
wlog: x y / x < y.
- case: (ltgtP x y) => Hcmp H neq hk xk yk //.
  + by rewrite (H x y Hcmp _ hk xk yk).
  rewrite (H y x Hcmp _ hk yk xk) //.
  move => Hcontra; by apply neq.
move => y_le_x _ ksz Hx Hy.
move: (Hx ksz) (Hy ksz) => /andP [lex gtx] /andP [ley gty] {Hx Hy}.
have lex_subs_ley: subseq [seq x' <- xs | x' <= x] [seq x' <- xs | x' < y].
  apply subset_filter_impl => t tleqx.
  by apply (le_lt_trans tleqx y_le_x).
move: (size_subseq lex_subs_ley).
rewrite -(leq_add2r (size [seq x0 <- xs | x < x0])).
have sizexs_eq: size [seq x' <- xs | x' <= x] + size [seq x0 <- xs | x < x0] = size xs.
  apply filter_size_neg_pred.
  move => a.
  by apply (leNgt a x).
rewrite sizexs_eq.
have sizexs_le: size [seq x <- xs | x < y] + size [seq x0 <- xs | x < x0] < k + (size xs - k).
  by apply leq_le_add; [apply ley | apply gtx].
have sizexs_le_eq: k + (size xs - k) = size xs.
  by rewrite addnC subnK //; apply (ltW ksz).
rewrite {}sizexs_le_eq in sizexs_le.
move => sizexs_leq.
have contra: size xs < size xs.
  by apply (@le_lt_trans _ _ _ (size xs) _ sizexs_leq sizexs_le).
by rewrite ltxx in contra.
Qed.

End Selection.


(** Instance for building logics by translating them to
 ** other logics.
 **)
Require Import ChargeCore.Logics.ILogic.
Require Import ChargeCore.Tactics.Tactics.

Section from_iso.
  Context {T U : Type} (f : T -> U) (g : U -> T) (ilo : ILogicOps T).

  Instance ILogicOps_iso : ILogicOps U :=
  {| lentails := fun l r => lentails (g l) (g r)
   ; ltrue := f ltrue
   ; lfalse := f lfalse
   ; land := fun l r => f (land (g l) (g r))
   ; lor := fun l r => f (lor (g l) (g r))
   ; limpl := fun l r => f (limpl (g l) (g r))
   ; lforall := fun T P => f (lforall (fun x => g (P x)))
   ; lexists := fun T P => f (lexists (fun x => g (P x)))
   |}.

  Context {il : ILogic T}.
  Hypothesis gf : forall x, g (f x) -|- x.

  Instance ILogic_iso : ILogic U.
  Proof.
    constructor; simpl; intros; repeat rewrite gf in *.
    { constructor.
      { red; simpl; intros; reflexivity. }
      { red; simpl; intros. etransitivity; eassumption. } }
    all: try charge_tauto.
    apply lfalseL.
    eapply lforallL; eauto.
    eapply lforallR; eauto.
    eapply lexistsL; eauto.
    eapply lexistsR; eauto.
    apply lorL; eauto.
  Defined.
End from_iso.
Arguments ILogicOps_iso {_ _} _ _ {_}.
Arguments ILogic_iso {_ _} [_ _ _] {_} _.

Hint Extern 10 (@ILogic _ _) =>
  (eapply ILogic_iso ;
     [ eauto with typeclass_instances
     | intro; eapply RelationClasses.PreOrder_Reflexive ]) : typeclass_instances.


Require Import BinNat.

From Proyecto Require Export Defs_Trie.
From Proyecto Require Export Props_Misc.

(* Teorema: Podemos construir con trie1 o con smartTrie1 sin afectar lookup1 *)
Theorem lookup_cons_indep1: forall (t1 t2: binTrie1) (k: N),
lookup1 k (trie1 t1 t2) = lookup1 k (smartTrie1 t1 t2).
Proof.
intros.
destruct t1, t2; simpl; trivial.
apply obvious_if.
Qed.

(* Mismos teoremas para trie2 y trie3 *)

Theorem lookup_cons_indep2: forall (t1 t2: binTrie2) (k: N),
lookup2 k (trie2 t1 t2) = lookup2 k (smartTrie2 t1 t2).
Proof.
intros.
destruct t1 eqn:T1; destruct t2 eqn:T2; simpl; trivial.
+ apply obvious_if.
+ Admitted.