Library Top.definition

Require Import Metalib.Metatheory.
Require Import Program.Equality.

The locally nameless representation represents bound variables through de Bruijn indices; therefore we have bound variable bvar and free variable fvar
Inductive typ : Set :=
| typ_top : typ
| typ_nat : typ
| typ_bvar : nat typ
| typ_fvar : var typ
| typ_mu : typ typ
| typ_arrow : typ typ typ.

Coercion typ_bvar : nat >-> typ.
Coercion typ_fvar : atom >-> typ.

Fixpoint open_tt_rec (K : nat) (U : typ) (T : typ) {struct T} : typ :=
  match T with
  | typ_nattyp_nat
  | typ_toptyp_top
  | typ_bvar Jif K === J then U else (typ_bvar J)
  | typ_fvar Xtyp_fvar X
  | typ_arrow T1 T2typ_arrow (open_tt_rec K U T1) (open_tt_rec K U T2)
  | typ_mu Ttyp_mu (open_tt_rec (S K) U T)
  end.

Definition open_tt T U := open_tt_rec 0 U T.

Types as locally closed pre-types

Inductive type : typ Prop :=
  | type_top :
      type typ_top
  | type_nat :
      type typ_nat
  | type_var : X,
      type (typ_fvar X)
  | type_arrow : T1 T2,
      type T1
      type T2
      type (typ_arrow T1 T2)
  | type_mu : L T,
      ( X, X \notin L type (open_tt T (typ_fvar X)))
      type (typ_mu T).

Hint Constructors type : core.

Substitution
Fixpoint subst_tt (Z : atom) (U : typ) (T : typ) {struct T} : typ :=
  match T with
  | typ_toptyp_top
  | typ_nattyp_nat
  | typ_bvar Jtyp_bvar J
  | typ_fvar Xif X == Z then U else (typ_fvar X)
  | typ_arrow T1 T2typ_arrow (subst_tt Z U T1) (subst_tt Z U T2)
  | typ_mu Ttyp_mu (subst_tt Z U T)
  end.

Fixpoint fv_tt (T : typ) {struct T} : atoms :=
  match T with
  | typ_top{}
  | typ_nat{}
  | typ_bvar J{}
  | typ_fvar X{{ X }}
  | typ_arrow T1 T2(fv_tt T1) `union` (fv_tt T2)
  | typ_mu T ⇒ (fv_tt T)
  end.

Inductive binding : Set :=
  | bind_sub : binding
  | bind_typ : typ binding.

Definition env := list (atom × binding).
Notation empty := (@nil (atom × binding)).

n-times finite unfolding (locally nameless version)
Fixpoint unfoldT (A : typ) X (n : nat) :=
  match n with
  | 0 ⇒ open_tt A (typ_fvar X)
  | (S i) ⇒ open_tt A (unfoldT A X i)
  end.

Well-formed Type (declarative version)
Inductive WFS : env typ Prop :=
| WFS_top : E, WFS E typ_top
| WFS_nat : E, WFS E typ_nat
| WFS_fvar : X E,
    binds X bind_sub E
    WFS E (typ_fvar X)
| WFS_arrow : E A B,
    WFS E A
    WFS E B
    WFS E (typ_arrow A B)
| WFS_rec : L E A,
      ( n X, X \notin L
        WFS (X ¬ bind_sub ++ E) (unfoldT A X n))
      WFS E (typ_mu A).

Well-formed Environment
Inductive wf_env : env Prop :=
  | wf_env_empty :
      wf_env empty
  | wf_env_sub : (E : env) (X : atom),
      wf_env E
      X \notin dom E
      wf_env (X ¬ bind_sub ++ E)
  | wf_env_typ : (E : env) (x : atom) (T : typ),
      wf_env E
      WFS E T
      x `notin` dom E
      wf_env (x ¬ bind_typ T ++ E).

Inductive exp : Set :=
  | exp_bvar : nat exp
  | exp_fvar : atom exp
  | exp_abs : typ exp exp
  | exp_app : exp exp exp
  | exp_nat : exp
  | exp_unfold : typ exp exp
  | exp_fold : typ exp exp
.

Coercion exp_bvar : nat >-> exp.
Coercion exp_fvar : atom >-> exp.

Fixpoint open_ee_rec (k : nat) (f : exp) (e : exp) {struct e} : exp :=
  match e with
  | exp_bvar iif k == i then f else (exp_bvar i)
  | exp_fvar xexp_fvar x
  | exp_abs t e1exp_abs t (open_ee_rec (S k) f e1)
  | exp_app e1 e2exp_app (open_ee_rec k f e1) (open_ee_rec k f e2)
  | exp_natexp_nat
  | exp_unfold T eexp_unfold T (open_ee_rec k f e)
  | exp_fold T eexp_fold T (open_ee_rec k f e)
  end.

Notation open_ee e1 e2 := (open_ee_rec 0 e2 e1).

Fixpoint subst_ee (y:atom) (u:exp) (e:exp) {struct e} : exp :=
  match e with
  | (exp_bvar n) ⇒ exp_bvar n
  | (exp_fvar x) ⇒ (if x == y then u else (exp_fvar x))
  | (exp_abs T e1) ⇒ exp_abs T (subst_ee y u e1)
  | (exp_app e1 e2) ⇒ exp_app (subst_ee y u e1) (subst_ee y u e2)
  | exp_natexp_nat
  | exp_unfold T eexp_unfold T (subst_ee y u e)
  | exp_fold T eexp_fold T (subst_ee y u e)
  end.

Fixpoint fv_exp (e_5:exp) : vars :=
  match e_5 with
  | (exp_bvar nat) ⇒ {}
  | (exp_fvar x) ⇒ {{x}}
  | (exp_abs T e) ⇒ fv_exp e
  | (exp_app e1 e2) ⇒ fv_exp e1 \u fv_exp e2
  | exp_nat{}
  | exp_unfold T efv_exp e
  | exp_fold T efv_exp e
  end.

Inductive expr : exp Prop :=
 | lc_fvar : (x:var),
     expr (exp_fvar x)
 | lc_abs : (e:exp) L T,
     ( x, x \notin L expr (open_ee e (exp_fvar x)))
     type T
     expr (exp_abs T e)
 | lc_app : (e1 e2:exp),
     expr e1
     expr e2
     expr (exp_app e1 e2)
 | lc_nat :
     expr exp_nat
 | lc_unfold: T e,
     type T
     expr e
     expr (exp_unfold T e)
 | lc_fold: T e,
     type T
     expr e
     expr (exp_fold T e).

Declarative subtyping
Inductive Sub : env typ typ Prop :=
| SA_nat: E,
    wf_env E
    Sub E typ_nat typ_nat
| SA_fvar: E X,
    wf_env E
    binds X bind_sub E
    Sub E (typ_fvar X) (typ_fvar X)
| SA_top : E A,
    wf_env E
    WFS E A
    Sub E A typ_top
| SA_arrow: E A1 A2 B1 B2,
    Sub E B1 A1
    Sub E A2 B2
    Sub E (typ_arrow A1 A2) (typ_arrow B1 B2)
| SA_rec: L A1 A2 E,
    ( n X,
        X \notin L
        Sub ((X ¬ bind_sub) ++ E) (unfoldT A1 X n) (unfoldT A2 X n))
    Sub E (typ_mu A1) (typ_mu A2).

Typing
Inductive typing : env exp typ Prop :=
| typing_nat: G,
    wf_env G
    typing G (exp_nat) (typ_nat)
| typing_var : (G:env) (x:var) (T:typ),
     wf_env G
     binds x (bind_typ T) G
     typing G (exp_fvar x) T
 | typing_abs : (L:vars) (G:env) (T1:typ) (e:exp) (T2:typ),
     ( x , x \notin L typing ((x ¬ bind_typ T1) ++ G) (open_ee e x) T2)
     typing G (exp_abs T1 e) (typ_arrow T1 T2)
 | typing_app : (G:env) (e1 e2:exp) (T2 T1:typ),
     typing G e1 (typ_arrow T1 T2)
     typing G e2 T1
     typing G (exp_app e1 e2) T2
 | typing_fold : G A e ,
     typing G e (open_tt A (typ_mu A))
     WFS G (typ_mu A)
     typing G (exp_fold (typ_mu A) e) (typ_mu A)
 | typing_unfold : G T e,
     typing G e (typ_mu T)
     typing G (exp_unfold (typ_mu T) e) (open_tt T (typ_mu T))
 | typing_sub: G T e S ,
     typing G e S
     Sub G S T
     typing G e T.

Inductive value : exp Prop :=
  | value_abs : t1 T,
      expr (exp_abs T t1)
      value (exp_abs T t1)
  | value_nat:
      value exp_nat
  | value_fold: T e,
      type T
      value e
      value (exp_fold T e).

Reduction
Inductive step : exp exp Prop :=
 | step_beta : (e1 e2:exp) T,
     expr (exp_abs T e1)
     value e2
     step (exp_app (exp_abs T e1) e2) (open_ee e1 e2)
 | step_app1 : (e1 e2 e1':exp),
     expr e2
     step e1 e1'
     step (exp_app e1 e2) (exp_app e1' e2)
 | step_app2 : v1 e2 e2',
     value v1
     step e2 e2'
     step (exp_app v1 e2) (exp_app v1 e2')
 | step_fld: S T v,
     value v
     type T
     type S
     step (exp_unfold S (exp_fold T v)) v
 | step_fold: e e' T,
     step e e'
     type T
     step (exp_fold T e) (exp_fold T e')
 | step_unfold: e e' T,
     step e e'
     type T
     step (exp_unfold T e) (exp_unfold T e').

Ltac gather_atoms ::=
  let A := gather_atoms_with (fun x : atomsx) in
  let B := gather_atoms_with (fun x : atomsingleton x) in
  let E := gather_atoms_with (fun x : typfv_tt x) in
  let C := gather_atoms_with (fun x : list (var × typ) ⇒ dom x) in
  let D := gather_atoms_with (fun x : expfv_exp x) in
  let F := gather_atoms_with (fun x : envdom x) in
  constr:(A `union` B `union` E \u C \u D \u F).

Well-formed Type (algorithmic version)
Inductive WF : env typ Prop :=
| WF_top : E, WF E typ_top
| WF_nat : E, WF E typ_nat
| WF_fvar : X E,
    binds X bind_sub E
    WF E (typ_fvar X)
| WF_arrow : E A B,
    WF E A
    WF E B
    WF E (typ_arrow A B)
| WF_rec : L E A,
      ( X, X \notin L
        WF (X ¬ bind_sub ++ E) (open_tt A X))
      WF E (typ_mu A).

Algorithmic subtyping
Inductive sub : env typ typ Prop :=
| sa_nat: E,
    wf_env E
    sub E typ_nat typ_nat
| sa_fvar: E X,
    wf_env E
    binds X bind_sub E
    sub E (typ_fvar X) (typ_fvar X)
| sa_top : E A,
    wf_env E
    WF E A
    sub E A typ_top
| sa_arrow: E A1 A2 B1 B2,
    sub E B1 A1
    sub E A2 B2
    sub E (typ_arrow A1 A2) (typ_arrow B1 B2)
| sa_rec: L A1 A2 E,
    ( X,
        X \notin L
        sub (X ¬ bind_sub ++ E) (open_tt A1 X) (open_tt A2 X))
    ( X,
        X \notin L
        sub (X ¬ bind_sub ++ E) (open_tt A1 (open_tt A1 X)) (open_tt A2 (open_tt A2 X)))
    sub E (typ_mu A1) (typ_mu A2).

Inductive Mode := Neg | Pos.

Definition flip (m : Mode) : Mode :=
  match m with
  | NegPos
  | PosNeg
  end.

Subtyping Subderivation
Inductive Der : Mode env typ typ env typ typ Prop :=
| DRefl : A B E, Sub E A B Der Pos nil A B E A B
| DFun1 : E1 E2 A1 A2 B1 B2 A B m,
    Der m E2 (typ_arrow A1 A2) (typ_arrow B1 B2) E1 A B
    Der m E2 A2 B2 E1 A B
| DFun2 : E1 E2 A1 A2 B1 B2 A B m,
    Der m E2 (typ_arrow A1 A2) (typ_arrow B1 B2) E1 A B
    Der (flip m) E2 B1 A1 E1 A B
| D_mu : E1 E2 A B C D m X n,
    Der m E2 (typ_mu A) (typ_mu B) E1 C D
    X \notin (union (fv_tt A) (fv_tt B)) \u fv_tt C \u fv_tt D \u dom E2 \u dom E1
    Der m (X ¬ bind_sub ++ E2) (unfoldT A X n) (unfoldT B X n) E1 C D.

Negative Subtyping
Inductive NTyp : env Mode atom typ typ Prop :=
| NBase : X E, NTyp E Neg X (typ_fvar X) (typ_fvar X)
| NRight : m B A C D X E, NTyp E m X B D NTyp E m X (typ_arrow A B) (typ_arrow C D)
| NLeft : m A B C D X E, NTyp E (flip m) X C A NTyp E m X (typ_arrow A B) (typ_arrow C D)
| NMu : A B m X n E L,
    ( X0, X0 \notin L NTyp (X0 ¬ bind_sub ++ E) m X (unfoldT A X0 n) (unfoldT B X0 n))
    NTyp E m X (typ_mu A) (typ_mu B).

Hint Constructors Sub WFS typing step value expr wf_env sub WF Der NTyp: core.

Fixpoint UnfoldS n X A :=
  match n with
  | 0 ⇒ A
  | S isubst_tt X (UnfoldS i X A) A
  end.

Definition chooseD(n : nat) (m : Mode) X (C : typ) (D : typ) :=
  match m with
  | Possubst_tt X (subst_tt X (UnfoldS n X C) C)
  | Negsubst_tt X (subst_tt X (UnfoldS n X D) D)
  end.

Definition chooseS (m : Mode) X (C : typ) (D : typ) :=
  match m with
  | Possubst_tt X C
  | Negsubst_tt X D
  end.

Definition 1
Fixpoint def1 (X: atom) (A: typ) (n:nat): typ :=
  match n with
  | 0 ⇒ A
  | S n1subst_tt X (def1 X A n1) A
  end.