Require Import String.
Require Import Coq.Structures.Equalities.
Require Import Coq.MSets.MSetInterface.
Require Import Arith.
Require Import Setoid.
Require Import SystemF.

Module Definitions4
       (Import VarTyp : UsualDecidableTypeFull)
       (Import set : MSetInterface.S).

Module SF := SysF(VarTyp)(set).
Export SF.

(* Notes:

The syntax is encoded using Charguéraud's Locally nameless representation:

http://www.chargueraud.org/softs/ln/

 *)

(* Our calculus: *)

Inductive PTyp : Type :=
  | PInt : PTyp
  | Fun : PTyp -> PTyp -> PTyp
  | And : PTyp -> PTyp -> PTyp
  | PBVarT : nat -> PTyp
  | PFVarT : var -> PTyp
  | ForAll : PTyp -> PTyp -> PTyp (* disjoint constraint *)
  | Top : PTyp.

Fixpoint ptyp2styp (t : PTyp) : STyp :=
  match t with
    | PInt => STInt
    | Fun t1 t2 => STFun (ptyp2styp t1) (ptyp2styp t2)
    | And t1 t2 => STTuple (ptyp2styp t1) (ptyp2styp t2)
    | PBVarT n => STBVarT n
    | PFVarT v => STFVarT v
    | ForAll _ t => STForAll (ptyp2styp t)
    | Top => STUnitT
  end.

Notation "'|' t '|'" := (ptyp2styp t) (at level 60).

Fixpoint open_rec_typ_source (k : nat) (u : PTyp) (t : PTyp) {struct t} : PTyp :=
  match t with
  | PInt        => PInt
  | Fun t1 t2   => Fun (open_rec_typ_source k u t1) (open_rec_typ_source k u t2)
  | And t1 t2   => And (open_rec_typ_source k u t1) (open_rec_typ_source k u t2)
  | PFVarT x    => PFVarT x
  | PBVarT i    => if Nat.eqb k i then u else (PBVarT i)
  | ForAll d t => ForAll (open_rec_typ_source k u d) (* d comes before forall *)
                        (open_rec_typ_source (S k) u t)
  | Top         => Top
  end.

Definition open_typ_source (t : PTyp) u := open_rec_typ_source 0 u t.

Fixpoint subst_typ_source (z : var) (u : PTyp) (t : PTyp) {struct t} : PTyp :=
  match t with
  | PInt        => PInt
  | Fun t1 t2   => Fun (subst_typ_source z u t1) (subst_typ_source z u t2)
  | And t1 t2   => And (subst_typ_source z u t1) (subst_typ_source z u t2)
  | PFVarT x    => if VarTyp.eqb x z then u else (PFVarT x)
  | PBVarT i    => PBVarT i
  | ForAll d t  => ForAll (subst_typ_source z u d) (subst_typ_source z u t)
  | Top         => Top
  end.

Fixpoint fv_ptyp (pTyp : PTyp) : vars :=
  match pTyp with
    | PInt        => empty
    | Fun t1 t2   => union (fv_ptyp t1) (fv_ptyp t2)
    | And t1 t2   => union (fv_ptyp t1) (fv_ptyp t2)
    | PBVarT n    => empty
    | PFVarT v    => singleton v
    | ForAll d t  => union (fv_ptyp d) (fv_ptyp t)
    | Top         => empty
  end.

Inductive PType : PTyp -> Prop :=
  | PType_Var : forall x, PType (PFVarT x)
  | PType_Int : PType PInt
  | PType_Fun : forall t1 t2, PType t1 -> PType t2 -> PType (Fun t1 t2)
  | PType_And : forall t1 t2, PType t1 -> PType t2 -> PType (And t1 t2)
  | PType_ForAll : forall L d t,
                     PType d ->
                     (forall x, not (In x L) -> PType (open_typ_source t (PFVarT x))) ->
                     PType (ForAll d t)
  | PType_Top : PType Top.

Hint Constructors PType.

Inductive Atomic : PTyp -> Prop :=
  | AInt : Atomic PInt
  | AFun : forall t1 t2, Atomic (Fun t1 t2)
  | AVar : forall v, Atomic (PFVarT v)
  | AForAll : forall d t, Atomic (ForAll d t).
(*  | ATop : Atomic Top. *)

(* Subtyping relation *)

Inductive usub : PTyp -> PTyp -> Prop :=
  | USInt : usub PInt PInt
  | USFun : forall o1 o2 o3 o4, usub o3 o1 -> usub o2 o4 -> usub (Fun o1 o2) (Fun  o3 o4)
  | USAnd1 : forall t t1 t2, usub t t1 -> usub t t2 -> usub t (And  t1 t2)
  | USAnd2 : forall t t1 t2 , usub t1 t -> PType t2 -> usub (And t1 t2) t
  | USAnd3 : forall t t1 t2, usub t2 t -> PType t1 -> usub (And t1 t2) t
  | USVar   : forall v, usub (PFVarT v) (PFVarT v)
  | USForAll : forall L d t1 t2,
                 (forall x, not (In x L) -> usub (open_typ_source t1 (PFVarT x))
                                           (open_typ_source t2 (PFVarT x))) ->
                 PType d ->
                 usub (ForAll d t1) (ForAll d t2)
  | USTop : forall t, PType t -> usub t Top.

Fixpoint and_coercion (t : PTyp) (e : SExp var) {struct t} : sum (SExp var) (SExp var).
refine(
  match t with
    | PInt => inr e
    | Fun _ B => match (and_coercion B e) with
                  | inl l => inl (STLam _ l)
                  | inr r => inr r
                 end
    | And A B => match (and_coercion A e, and_coercion B e) with
                  | (inl l1, inl l2) =>
                    inl (STPair _ l1 l2)
                  | _ => inr e
                end
    | PBVarT _  => inr e
    | PFVarT _ => inr e
    | ForAll d A => inr e
    | TopT    => inl (STUnit _)
  end).
Defined.
(*
pick_fresh x.
destruct (and_coercion (open_typ_source A (PFVarT x)) e).
apply (inl (STTLam _ s)).
apply (inr s).
Admitted. *)

Definition join_sum : forall {A}, A + A -> A.
  intros A H; destruct H as [a | a]; exact a.
Defined.

Inductive sub : PTyp -> PTyp -> (SExp var) -> Prop :=
  | SInt : sub PInt PInt (STLam _ (STBVar _ 0))
  | SFun : forall o1 o2 o3 o4 c1 c2,
             sub o3 o1 c1 ->
             sub o2 o4 c2 ->
             sub (Fun o1 o2) (Fun o3 o4) (STLam _ (STLam _ (STApp _ c2 (STApp _ (STBVar _ 1) (STApp _ c1 (STBVar _ 0))))))
  | SAnd1 : forall t t1 t2 c1 c2,
              sub t t1 c1 ->
              sub t t2 c2 ->
              sub t (And t1 t2) (STLam _ (STPair _ (STApp _ c1 (STBVar _ 0)) (STApp _ c2 (STBVar _ 0))))
  | SAnd2 : forall t t1 t2 c,
              sub t1 t c ->
              Atomic t ->
              PType t2 ->
              sub (And t1 t2) t (STLam _ (join_sum (and_coercion t ((STApp _ c (STProj1 _ (STBVar _ 0)))))))
  | SAnd3 : forall t t1 t2 c,
              sub t2 t c ->
              Atomic t ->
              PType t1 ->
              sub (And t1 t2) t (STLam _ (join_sum (and_coercion t ((STApp _ c (STProj2 _ (STBVar _ 0)))))))
  | SVar : forall v, sub (PFVarT v) (PFVarT v) (STLam _ (STBVar _ 0))
  | SForAll : forall L d t1 t2 c,
                (forall x, not (In x L) -> sub (open_typ_source t1 (PFVarT x))
                                         (open_typ_source t2 (PFVarT x))
                                         (open_typ_term c (STFVarT x))) ->
                PType d ->
                sub (ForAll d t1) (ForAll d t2)
                    (STLam _ (STTLam _ (STApp _ c (STTApp _ (STBVar _ 0) (STBVarT 0)))))
  | STop : forall t, PType t -> sub t Top (STLam _ (STUnit _)).

Hint Constructors Atomic sub usub.

Definition Sub (t1 t2 : PTyp) : Prop := exists (e:SExp var), sub t1 t2 e.

Lemma sub_lc : forall t1 t2, Sub t1 t2 -> PType t1 /\ PType t2.
Proof.
  intros t1 t2 HSub.
  destruct HSub.
  induction H; eauto.
  - destruct IHsub1, IHsub2; auto.
  - destruct IHsub1, IHsub2; auto.
  - destruct IHsub; auto.
  - destruct IHsub; auto.
  - split.
    apply_fresh PType_ForAll as x; auto.
    assert (Ha : ~ In x L) by not_in_L x.
    apply H0 in Ha; now destruct Ha.
    apply_fresh PType_ForAll as x; auto.
    assert (Ha : ~ In x L) by not_in_L x.
    apply H0 in Ha; now destruct Ha.
Qed.

Hint Resolve sub_lc.

(* Smart constructors for Sub *)

Definition stop : forall t, PType t -> Sub t Top.
unfold Sub; eauto.
Defined.

Definition sint : Sub PInt PInt.
unfold Sub. exists (STLam _ (STBVar _ 0)).
exact SInt.
Defined.

Definition sfun : forall o1 o2 o3 o4, Sub o3 o1 -> Sub o2 o4 -> Sub (Fun o1 o2) (Fun  o3 o4).
unfold Sub; intros. destruct H. destruct H0.
exists (STLam _ (
       STLam _ (STApp _ x0 (STApp _ (STBVar _ 1) (STApp _ x (STBVar _ 0)))))).
apply SFun. auto. auto.
Defined.

Definition sand1 : forall t t1 t2, Sub t t1 -> Sub t t2 -> Sub t (And t1 t2).
unfold Sub. intros. destruct H. destruct H0.
exists (STLam _ (
       STPair _ (STApp _ x (STBVar _ 0)) (STApp _ x0 (STBVar _ 0)))).
apply SAnd1. auto. auto.
Defined.

Definition sand2_atomic :
  forall t t1 t2, Sub t1 t -> Atomic t -> PType t2 -> Sub (And  t1 t2) t.
  unfold Sub; intros t t1 t2 H H1 H0;
  destruct t; try (now inversion H1); destruct H; eauto.
Defined.

Definition sand2 : forall t t1 t2, Sub t1 t -> PType t2 -> Sub (And t1 t2) t.
  intro t.
  induction t; intros.
  (* Case PInt *)
  - apply sand2_atomic; auto.
  (* Case Fun *)
  - apply sand2_atomic; auto.
  (* Case And *)
  - unfold Sub. unfold Sub in H. destruct H. inversion H.
    assert (Sub (And t0 t3) t1). apply IHt1.
    unfold Sub. exists c1; auto. auto.
    assert (Sub (And t0 t3) t2). apply IHt2.
    unfold Sub. exists c2. auto. auto.
    unfold Sub in H7. destruct H7.
    unfold Sub in H8. destruct H8.
    exists (STLam _ (STPair _ (STApp _ x0 (STBVar _ 0)) (STApp _ x1 (STBVar _ 0)))).
    apply SAnd1. auto. auto.
    inversion H2.
    inversion H2.
  (* Case BVar *)
  - inversion H. inversion H1; inversion H3.
  (* Case FVar *)
  - apply sand2_atomic; auto.
  (* Case ForAll *)
  - apply sand2_atomic; auto; apply AForAll.
  (* Case Top *)
  - apply stop; auto.
    apply PType_And; auto.
    apply sub_lc in H; now destruct H.
Qed.

Definition sand3_atomic :
  forall t t1 t2, Sub t2 t -> Atomic t -> PType t1 -> Sub (And t1 t2) t.
  unfold Sub; intros t t1 t2 H H1 H0.
  destruct t; try (now inversion H1); destruct H; eauto.
Defined.

Definition sand3 : forall t t1 t2, Sub t2 t -> PType t1 -> Sub (And t1 t2) t.
  intros t; induction t; intros.
  (* Case PInt *)
  - apply sand3_atomic; auto.
  (* Case Fun *)
  - apply sand3_atomic; auto.
  (* Case And *)
  - unfold Sub. unfold Sub in H. destruct H. inversion H.
    assert (Sub (And t0 t3) t1). apply IHt1.
    unfold Sub. exists c1. auto. auto.
    assert (Sub (And t0 t3) t2). apply IHt2.
    unfold Sub. exists c2. auto. auto.
    unfold Sub in H7. destruct H7.
    unfold Sub in H8. destruct H8.
    exists (STLam _ (STPair _ (STApp _ x0 (STBVar _ 0)) (STApp _ x1 (STBVar _ 0)))).
    apply SAnd1. auto. auto.
    inversion H2.
    inversion H2.
  (* Case BVar *)
  - inversion H; inversion H1; inversion H3.
  (* Case FVar *)
  - apply sand3_atomic; auto.
  (* Case ForAll *)
  - apply sand3_atomic; auto; apply AForAll.
  (* Case Top *)
  - apply stop; auto.
    apply PType_And; auto.
    apply sub_lc in H; now destruct H.
Qed.

Definition svar : forall v, Sub (PFVarT v) (PFVarT v).
  intros.
  unfold Sub.
  exists (STLam _ (STBVar _ 0)).
  apply SVar.
Defined.

(*
Definition sforall : forall L t1 t2 c,
                (forall x, not (In x L) -> sub (open_ptyp t1 (PFVar x))
                                         (open_ptyp t2 (PFVar x))
                                         (open_typ_term c (STFVarT x))) ->
                Sub (ForAll t1) (ForAll t2).
  intros.
  unfold Sub.
  eexists.
  eapply SForAll.
  intros.

  pick_fresh.
 *)

(** Environment definitions **)

Inductive TyEnvSource : Type :=
  | TyDis : PTyp -> TyEnvSource
  | TermV : PTyp -> TyEnvSource.

Hint Constructors TyEnvSource.

Inductive WFEnv : context TyEnvSource -> Prop :=
  | WFNil : WFEnv nil
  | WFPushV : forall Gamma v ty,
                WFEnv Gamma -> not (In v (fv_ptyp ty)) -> ~ In v (dom Gamma) ->
                WFEnv (extend v (TyDis ty) Gamma)
  | WFPushT : forall Gamma v ty,
                WFEnv Gamma -> ~ In v (dom Gamma) -> WFEnv (extend v (TermV ty) Gamma).

Hint Constructors WFEnv.

Fixpoint subst_env (Gamma : context TyEnvSource) (z : var) (u : PTyp) :=
  match Gamma with
    | nil => nil
    | (x,TyDis d) :: tl => (x, TyDis (subst_typ_source z u d)) ::
                           (subst_env tl z u)
    | (x, TermV ty) :: tl => (x, TermV ty) :: (subst_env tl z u)
  end.

Definition MapsTo (Gamma : context TyEnvSource) (z : var) (d : PTyp) :=
  find (fun x => eqb (fst x) z) Gamma = Some (z, TyDis d).

Definition TyEnvMatch {A} (f : PTyp -> A) (tyenv : TyEnvSource) : A :=
  match tyenv with
    | TyDis d => f d
    | TermV ty => f ty
  end.

Definition codom (c : context TyEnvSource) : vars :=
  fold_right (fun el r => union (TyEnvMatch fv_ptyp (snd el)) r) empty c.

(* Disjointness: Implementation *)

Definition hd (p : PTyp) : nat :=
  match p with
  | PInt       => 0
  | Fun t1 t2  => 1
  | ForAll d t => 2
  | Top        => 3
  | PBVarT n   => 4
  | PFVarT v   => 5
  | And t1 t2  => 6
  end.

Definition OrthoAx (t1 t2 : PTyp) : Prop :=
  (hd t1 < 3 /\ hd t2 < 3 /\ not (hd t1 = hd t2)).

Inductive Ortho : context TyEnvSource -> PTyp -> PTyp -> Prop :=
  | OAnd1 : forall Gamma t1 t2 t3, Ortho Gamma t1 t3 -> Ortho Gamma t2 t3 -> Ortho Gamma (And t1 t2) t3
  | OAnd2 : forall Gamma t1 t2 t3, Ortho Gamma t1 t2 -> Ortho Gamma t1 t3 -> Ortho Gamma t1 (And t2 t3)
  | OFun  : forall Gamma t1 t2 t3 t4, Ortho Gamma t2 t4 -> Ortho Gamma (Fun t1 t2) (Fun t3 t4)
  | OForAll : forall L Gamma d t1 t2,
                (forall x, not (In x L) -> Ortho (extend x (TyDis d) Gamma)
                                           (open_typ_source t1 (PFVarT x))
                                           (open_typ_source t2 (PFVarT x))) ->
                Ortho Gamma (ForAll d t1) (ForAll d t2)
  | OVar : forall Gamma x ty A, List.In (x,TyDis A) Gamma ->
                       usub A ty ->
                       PType ty ->
                       Ortho Gamma (PFVarT x) ty
  | OVarSym : forall Gamma x ty A, List.In (x,TyDis A) Gamma ->
                          usub A ty ->
                          PType ty ->
                          Ortho Gamma ty (PFVarT x)
  | OTop1 : forall Gamma t, Ortho Gamma Top t
  | OTop2 : forall Gamma t, Ortho Gamma t Top
  | OAx : forall Gamma t1 t2, OrthoAx t1 t2 -> Ortho Gamma t1 t2.

Hint Constructors Ortho.

(* Disjointness: Specification *)

Definition OrthoS (A B : PTyp) := not (exists C, Sub A C /\ Sub B C).

(* Well-formed types *)

Inductive WFTyp : context TyEnvSource -> PTyp -> Prop :=
  | WFInt : forall Gamma, WFEnv Gamma -> WFTyp Gamma PInt
  | WFFun : forall Gamma t1 t2, WFTyp Gamma t1 -> WFTyp Gamma t2 -> WFTyp Gamma (Fun t1 t2)
  | WFAnd : forall Gamma t1 t2, WFTyp Gamma t1 -> WFTyp Gamma t2 -> Ortho Gamma t1 t2 -> WFTyp Gamma (And t1 t2)
  | WFVar : forall Gamma x ty, List.In (x,TyDis ty) Gamma -> WFEnv Gamma -> WFTyp Gamma (PFVarT x)
  | WFForAll : forall L Gamma d t,
                 (forall x, not (In x L) -> WFTyp (extend x (TyDis d) Gamma) (open_typ_source t (PFVarT x))) ->
                 WFTyp Gamma d ->
                 WFTyp Gamma (ForAll d t)
  | WFTop : forall Gamma, WFEnv Gamma -> WFTyp Gamma Top.

Hint Constructors WFTyp.

(* Reflexivity *)
Hint Resolve sint sfun sand1 sand2 sand3 svar SInt SFun SAnd1 SAnd2 SAnd3 SVar SForAll.

(* Definitions borrowed from STLC_Tutorial *)

(* Our source language *)
Inductive PExp :=
  | PUnit  : PExp
  | PFVar  : var -> PExp
  | PBVar  : nat -> PExp
  | PLit   : nat -> PExp
  | PLam   : PExp -> PExp
  | PApp   : PExp -> PExp -> PExp
  | PMerge : PExp -> PExp -> PExp
  | PAnn   : PExp -> PTyp -> PExp (* only for the algorithmic version *)
  | PTLam  : PTyp -> PExp -> PExp
  | PTApp  : PExp -> PTyp -> PExp.

(* Free variables *)

(** Source language **)
Fixpoint fv_source (pExp : PExp) : vars :=
  match pExp with
    | PUnit => empty
    | PFVar v => singleton v
    | PBVar _ => empty
    | PLit _ => empty
    | PLam t => fv_source t
    | PApp t1 t2 => union (fv_source t1) (fv_source t2)
    | PMerge t1 t2 => union (fv_source t1) (fv_source t2)
    | PAnn t1 A => fv_source t1
    | PTLam tydis t => union (fv_ptyp tydis) (fv_source t)
    | PTApp t ty => union (fv_source t) (fv_ptyp ty)
  end.

(* Tactics dealing with instantiation of fresh variables, taken from STLC_Tutorial *)

Ltac gather_vars :=
  let A := gather_vars_with (fun x : vars => x) in
  let B := gather_vars_with (fun x : var => singleton x) in
  let C := gather_vars_with (fun x : PExp => fv_source x) in
  let D := gather_vars_with (fun x : PTyp => fv_ptyp x) in
  let E := gather_vars_with (fun x : STyp => fv_typ x) in
  let F := gather_vars_with (fun (x : SExp var) => fv x) in
  let G := gather_vars_with (fun (x : context (TyEnv STyp)) => dom x) in
  let H := gather_vars_with (fun (x : context TyEnvSource) =>
                              union (dom x) (codom x)) in
  constr:(union A (union B (union C (union D (union E (union F (union G H))))))).

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

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

(* Opening a term "u" with term "t" *)

(** Source language **)
Fixpoint open_rec_source (k : nat) (u : PExp) (t : PExp) {struct t} : PExp  :=
  match t with
  | PUnit        => PUnit
  | PBVar i      => if Nat.eqb k i then u else (PBVar i)
  | PFVar x      => PFVar x
  | PLit x       => PLit x
  | PLam t1      => PLam (open_rec_source (S k) u t1)
  | PApp t1 t2   => PApp (open_rec_source k u t1) (open_rec_source k u t2)
  | PMerge t1 t2 => PMerge (open_rec_source k u t1) (open_rec_source k u t2)
  | PAnn e t     => PAnn (open_rec_source k u e) t
  | PTLam ty t   => PTLam ty (open_rec_source k u t)
  | PTApp t ty   => PTApp (open_rec_source k u t) ty
  end.

Fixpoint open_rec_typ_term_source (k : nat) (u : PTyp) (t : PExp) {struct t} : PExp :=
  match t with
  | PUnit        => PUnit
  | PBVar i      => PBVar i
  | PFVar x      => PFVar x
  | PLit x       => PLit x
  | PLam t1      => PLam (open_rec_typ_term_source k u t1)
  | PApp t1 t2   => PApp (open_rec_typ_term_source k u t1)
                        (open_rec_typ_term_source k u t2)
  | PMerge t1 t2 => PMerge (open_rec_typ_term_source k u t1)
                          (open_rec_typ_term_source k u t2)
  | PAnn e t     => PAnn (open_rec_typ_term_source k u e) t
  | PTLam ty t   => PTLam ty (open_rec_typ_term_source (S k) u t)
  | PTApp t ty   => PTApp (open_rec_typ_term_source k u t)
                         (open_rec_typ_source k u ty)
  end.

Definition open_source t u := open_rec_source 0 u t.
Definition open_typ_term_source t u := open_rec_typ_term_source 0 u t.

(* Functions on contexts *)

Definition ptyp2styp_tyenv (t : TyEnvSource) : TyEnv STyp :=
  match t with
    | TyDis _ => TyVar _
    | TermV t => TermVar _ (ptyp2styp t)
  end.

Definition conv_context (env : context TyEnvSource) : context (TyEnv STyp) :=
  mapctx ptyp2styp_tyenv env.

Notation "'∥' t '∥'" := (conv_context t) (at level 60).

Inductive PTerm : PExp -> Prop :=
  | PTerm_Unit :
      PTerm PUnit
  | PTerm_Var : forall x,
      PTerm (PFVar x)
  | PTerm_Lit : forall n,
      PTerm (PLit n)
  | PTerm_Lam : forall L t1,
      (forall x, not (In x L) -> PTerm (open_source t1 (PFVar x))) ->
      PTerm (PLam t1)
  | PTerm_App : forall t1 t2,
      PTerm t1 ->
      PTerm t2 ->
      PTerm (PApp t1 t2)
  | PTerm_Merge : forall t1 t2,
      PTerm t1 ->
      PTerm t2 ->
      PTerm (PMerge t1 t2)
  | PTerm_Ann : forall e t,
      PTerm e ->
      PTerm (PAnn e t)
  | PTerm_TLam : forall L t ty,
      (forall x, not (In x L) -> PTerm (open_typ_term_source t (PFVarT x))) ->
      PTerm (PTLam ty t)
  | PTerm_TApp : forall t ty,
      PTerm t ->
      PType ty ->
      PTerm (PTApp t ty).

Hint Constructors PTerm.

Inductive Dir := Inf | Chk.

(* bidirection type-system (algorithmic):

T |- e => t ~> E     (inference mode: infers the type of e producing target E) (use Inf)
T |- e <= t ~> E     (checking mode: checks the type of e producing target E) (use Chk)

Inspiration for the rules:

https://www.andres-loeh.de/LambdaPi/LambdaPi.pdf

 *)

Inductive has_type_source_alg : context TyEnvSource -> PExp -> Dir -> PTyp -> (SExp var) -> Prop :=
  (* Inference rules *)
  | ATyTop : forall Gamma, WFEnv Gamma -> has_type_source_alg Gamma PUnit Inf Top (STUnit _)
  | ATyVar : forall Gamma x ty, WFEnv Gamma -> List.In (x,TermV ty) Gamma -> WFTyp Gamma ty ->
                      has_type_source_alg Gamma (PFVar x) Inf ty (STFVar _ x)
  | ATyLit : forall Gamma x, WFEnv Gamma -> has_type_source_alg Gamma (PLit x) Inf PInt (STLit _ x)
  | ATyApp : forall Gamma A B t1 t2 E1 E2,
              has_type_source_alg Gamma t1 Inf (Fun A B) E1 ->
              has_type_source_alg Gamma t2 Chk A E2 ->
              has_type_source_alg Gamma (PApp t1 t2) Inf B (STApp _ E1 E2)
  | ATyMerge : forall Gamma A B t1 t2 E1 E2,
                has_type_source_alg Gamma t1 Inf A E1 ->
                has_type_source_alg Gamma t2 Inf B E2 ->
                Ortho Gamma A B ->
                has_type_source_alg Gamma (PMerge t1 t2) Inf (And A B) (STPair _ E1 E2)
  | ATyAnn : forall Gamma t1 A E, has_type_source_alg Gamma t1 Chk A E ->
                         has_type_source_alg Gamma (PAnn t1 A) Inf A E
  | ATyTApp : forall Gamma t A ty d E,
                WFTyp Gamma A ->
                has_type_source_alg Gamma t Inf (ForAll d ty) E ->
                Ortho Gamma A d ->
                has_type_source_alg Gamma (PTApp t A) Inf (open_typ_source ty A) (STTApp _ E (|A|))
  (* Checking rules *)
  | ATyLam : forall L Gamma t A B E,
               (forall x, not (In x L) ->
                     has_type_source_alg (extend x (TermV A) Gamma) (open_source t (PFVar x)) Chk B (open E (STFVar _ x))) ->
               WFTyp Gamma A ->
               has_type_source_alg Gamma (PLam t) Chk (Fun A B) (STLam _ E)
  | ATySub : forall Gamma t A B C E,
               has_type_source_alg Gamma t Inf A E ->
               sub A B C ->
               WFTyp Gamma B ->
               has_type_source_alg Gamma t Chk B (STApp _ C E)
  | ATyTLam : forall L Gamma t A d E,
               WFTyp Gamma d ->
               (forall x, not (In x L) ->
                     has_type_source_alg (extend x (TyDis d) Gamma)
                                         (open_typ_term_source t (PFVarT x))
                                         Chk
                                         (open_typ_source A (PFVarT x))
                                         (open_typ_term E (STFVarT x))) ->
               has_type_source_alg Gamma (PTLam d t) Chk (ForAll d A) (STTLam _ E).

Hint Constructors has_type_source_alg.

Lemma decidability_types :
  forall (A B : PTyp), sumbool (A = B) (not (A = B)).
Proof.
  decide equality.
  case_eq (Nat.eqb n n0); intros.
  left; apply beq_nat_true in H; auto.
  right; apply beq_nat_false in H.
  unfold not; intros H1; inversion H1; contradiction.
  apply VarTyp.eq_dec.
Qed.

Hint Resolve decidability_types.

Module PTypDecidable <: DecidableType.

  Definition t := PTyp.

  Definition eq (x : PTyp) y := (x = y).

  Definition eq_refl : forall x : t, eq x x.
    Proof. destruct x; reflexivity. Defined.

  Definition eq_sym : forall x y : t, eq x y -> eq y x.
    Proof. destruct x; destruct y; intros; auto; symmetry; assumption. Defined.

  Definition eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
    Proof. intros; rewrite H; assumption. Defined.

  Definition eq_equiv : Equivalence eq :=
    Build_Equivalence _ eq_refl eq_sym eq_trans.

  Definition eq_dec : forall x y, sumbool (eq x y) (not (eq x y)).
    Proof. apply decidability_types. Defined.

End PTypDecidable.

Import PTypDecidable.
Require Import Coq.Structures.DecidableTypeEx.

Module VarTypDecidable <: DecidableType.

  Definition t := VarTyp.t.

  Definition eq (x : VarTyp.t) y := (VarTyp.eq x y).

  Definition eq_equiv : Equivalence eq.
    Proof. apply VarTyp.eq_equiv. Defined.

  Definition eq_refl : forall x : t, eq x x.
    Proof. apply reflexivity. Defined.

  Definition eq_sym : forall x y : t, eq x y -> eq y x.
    Proof. intros; symmetry; assumption. Defined.

  Definition eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
    Proof. intros; rewrite H; assumption. Defined.

  Definition eq_dec : forall x y, sumbool (eq x y) (not (eq x y)).
    Proof. apply VarTyp.eq_dec. Defined.

End VarTypDecidable.

Ltac orthoax_inv H :=
  let H' := fresh in
  let m := fresh in
  let H1 := fresh in
  let H2 := fresh in
  inversion H as [H' | m H1 H2 ]; orthoax_inv H1.

(* Solving goals by inversion, with the form OrthoAx t1 t2,
   where t1 is not part of OrthoAx *)
Ltac orthoax_inv_l :=
  match goal with
    | H: OrthoAx _ _ |- _ => let H1 := fresh in
                           destruct H as [H1 _]; orthoax_inv H1
  end.

(* Solving goals by inversion, with the form OrthoAx t1 t2,
   where t2 is not part of OrthoAx *)
Ltac orthoax_inv_r :=
  match goal with
    | H: OrthoAx _ _ |- _ => let H1 := fresh in
                           destruct H as [_ [H1 _]]; orthoax_inv H1
  end.

Lemma sound_sub : forall t1 t2, usub t1 t2 -> Sub t1 t2.
Proof.
  intros; induction H; auto.
  - unfold Sub.
    eexists.
    apply_fresh SForAll as x; auto.
    admit.
  - eexists; eauto.
Admitted.

Lemma complete_sub : forall t1 t2, Sub t1 t2 -> usub t1 t2.
Proof.
  intros; destruct H; induction H; auto.
  - apply_fresh USForAll as x.
    apply H0.
    not_in_L x.
    auto.
Qed.

End Definitions4.


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

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.
Set Implicit Arguments.

Import WfExtensionality.

Lemma subtype_sel_low_nom_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_low x1 L1 T1') ->
                  forall T2 L2 t T2', T2 = (t_nom L2 t T2') ->
                                 subtype T1 T2 = false.
Proof.
  intros.

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

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

Qed.


Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Export tools algebra language regexp words positive_regexp.

Section s.
  Context {atom : Set}{𝐀 : Atom atom}.
  Context {X : Set} {𝐗 : Alphabet 𝐀 X}.
  (** * Nominal structure *)
  Global Instance actReg : Action 𝐀 (@regexp letter) :=
    fix act p e {struct e} :=
      match e with
      | ⟪x⟫ => ⟪p∙x⟫
      | e_un => e_un
      | e_zero => e_zero
      | e_add e f => e_add (act p e) (act p f)
      | e_prod e f => e_prod (act p e) (act p f)
      | e_star e => e_star (act p e)
      end.

  Global Instance supReg : Support 𝐀 (@regexp letter) :=
    fix sup e {struct e} :=
      match e with
      | ⟪x⟫ => ⌊x⌋
      | e_un => []
      | e_zero => []
      | e_add e f => sup e ++ sup f
      | e_prod e f => sup e ++ sup f
      | e_star e => sup e
      end.

  Global Instance nominalReg : Nominal 𝐀 (@regexp letter).
  Proof.
    split.
    - intros e π; unfold act,act_lists at 1 ;rewrite map_eq_id;unfold support.
      induction e;simpl;simpl.
      + reflexivity.
      + reflexivity.
      + intros h;f_equal.
        * apply IHe1;intros a I;apply h.
          simpl_In;tauto.
        * apply IHe2;intros a I;apply h.
          simpl_In;tauto.
      + intros h;f_equal.
        * apply IHe1;intros a I;apply h.
          simpl_In;tauto.
        * apply IHe2;intros a I;apply h.
          simpl_In;tauto.
      + intros h;f_equal.
        apply IHe;intros a I;apply h,I.
      + intro h;f_equal;apply action_invariant,map_eq_id,h.
    - intros e π;unfold support;simpl.
      induction e;simpl;try rewrite act_lists_app||rewrite support_action;try reflexivity.
      + rewrite IHe1,IHe2;reflexivity.
      + rewrite IHe1,IHe2;reflexivity.
      + rewrite IHe;reflexivity.
    - intros e π1 π2;unfold act;induction e;simpl;try reflexivity||congruence.
      f_equal;apply action_compose.
  Qed.

  (** * Facts about the support *)
  Lemma support_lang e u : ⟦e⟧ u -> ⌊u⌋ ⊆ ⌊e⌋.
  Proof.
    revert u;induction e as [| |e IHe f IHf|e IHe f IHf|e|x].
    - intros ? F;simpl;exfalso;apply F.
    - intros ? ->;apply incl_nil.
    - intros u [Ie|If].
      + rewrite (IHe _ Ie).
        apply incl_appl;reflexivity.
      + rewrite (IHf _ If).
        apply incl_appr;reflexivity.
    - intros w (u&v&->&Ie&If).
      rewrite support_list_app,(IHe _ Ie),(IHf _ If).
      reflexivity.
    - intros w (n&In);revert w In;induction n;intros w;simpl.
      + intros ->;apply incl_nil.
      + intros (u&v&->&Ie&In).
        rewrite support_list_app,(IHe _ Ie),(IHn _ In);simpl.
        apply incl_app;reflexivity.
    - intros u ->;unfold support,SupportList;simpl.
      rewrite undup_equivalent,app_nil_r;reflexivity.
  Qed.

  Lemma Σ_support L : ⌊L⌋ ≈ ⌊Σ L⌋.
  Proof.
    induction L as [|e L];simpl.
    - reflexivity.
    - rewrite support_list_cons,IHL.
      reflexivity.
  Qed.

  Lemma prefixes_support e : ⌊prefixes e⌋ ⊆ ⌊e⌋.
  Proof.
    induction e;simpl.
    - reflexivity.
    - reflexivity.
    - rewrite support_list_app,IHe1,IHe2;reflexivity.
    - case_eq (test0 e1 || test0 e2).
      + intros;apply incl_nil.
      + intros F;rewrite support_list_app,IHe1.
        apply incl_app.
        * apply incl_appl;reflexivity.
        * intros a Ia.
          apply In_support_list in Ia as (f&If&Ia).
          apply in_map_iff in If as (g&<-&Ig).
          apply in_app_iff in Ia as [Ia|Ia].
          -- apply in_app_iff;left;apply Ia.
          -- apply in_app_iff;right;apply IHe2,In_support_list;exists g;tauto.
    - case_eq (test0 e).
      + intros;apply incl_nil.
      + intros F a Ia.
        apply In_support_list in Ia as (f&If&Ia).
        apply in_map_iff in If as (g&<-&Ig).
        apply in_app_iff in Ia as [Ia|Ia].
        * apply Ia.
        * apply IHe,In_support_list;exists g;tauto.
    - unfold support,SupportList at 1;simpl.
      rewrite app_nil_r,undup_equivalent;reflexivity.
  Qed.

  Lemma fresh_lang e a u : a # e -> ⟦e⟧ u -> a # u.
  Proof. intros F Iu Ia;apply F,(support_lang Iu),Ia. Qed.

  Lemma support_join e f : ⌊e∪f⌋ = ⌊e⌋++⌊f⌋.
  Proof. reflexivity. Qed.

  Lemma support_prod e f : ⌊e·f⌋ = ⌊e⌋++⌊f⌋.
  Proof. reflexivity. Qed.

  Lemma support_star e : ⌊e⋆⌋ = ⌊e⌋.
  Proof. reflexivity. Qed.

  Lemma support_Var e : ⌊e⌋ ≈ ⌊Var e⌋.
  Proof.
    induction e;simpl;try reflexivity.
    - replace e_add with join by reflexivity.
      rewrite support_join,support_list_app,IHe1,IHe2;reflexivity.
    - replace e_prod with prod by reflexivity.
      rewrite support_prod,support_list_app,IHe1,IHe2;reflexivity.
    - rewrite <- IHe;reflexivity.
    - unfold support,SupportList;simpl.
      rewrite app_nil_r,undup_equivalent;reflexivity.
  Qed.

  Lemma support_ϵ e : ⌊ϵ e⌋ = [].
  Proof. destruct (ϵ_zero_or_un e) as [-> | ->];reflexivity. Qed.

  (** * Facts about the group action *)
  Lemma act_lang e p u : ⟦p∙e⟧ u <-> ⟦e⟧ (p∗∙u).
  Proof.
    cut (forall e p u, ⟦p∙e⟧ u -> ⟦e⟧ (p∗∙u)).
    - intros hyp;split;[apply hyp|].
      rewrite <- (act_pinv_p (p∗) u) at 2.
      intros I;apply hyp;rewrite act_pinv_p;assumption.
    - clear;intros e p;induction e;intros u;simpl.
      + tauto.
      + intros ->;reflexivity.
      + intros [I|I].
        * apply IHe1 in I;left;tauto.
        * apply IHe2 in I;right;tauto.
      + intros (u1&u2&->&I1&I2).
        apply IHe1 in I1;apply IHe2 in I2.
        exists (p ∗∙u1),(p ∗∙ u2).
        rewrite act_lists_app;tauto.
      + intros (n&I);exists n;revert u I;induction n;simpl;intros.
        * rewrite I;reflexivity.
        * destruct I as (u1&u2&->&Iu&Iv).
          apply IHe in Iu.
          apply IHn in Iv.
          exists (p ∗∙u1),(p ∗∙ u2);rewrite act_lists_app;tauto.
      + intros ->;unfold act at 1;simpl.
        rewrite act_pinv_p;reflexivity.
  Qed.

    Lemma ϵ_act p e : ϵ (p∙e) = ϵ e.
  Proof.
    induction e;simpl;try reflexivity.
    - unfold act in *;rewrite IHe1,IHe2;reflexivity.
    - unfold act in *;rewrite IHe1,IHe2;reflexivity.
  Qed.

  Lemma δ_act p l e : δ l (p∙e) = p∙ δ (p∗∙l) e.
  Proof.
    induction e;simpl;try reflexivity;replace actReg with act by reflexivity.
    - rewrite IHe1,IHe2;reflexivity.
    - rewrite ϵ_act;rewrite IHe1,IHe2.
      unfold_eqX;reflexivity.
    - rewrite IHe;reflexivity.
    - replace eq_letter with (@tools.eqX _ dec_letter) by reflexivity.
      unfold_eqX;reflexivity||(exfalso;apply N;subst).
      + apply act_pinv_p.
      + symmetry;apply act_p_pinv.
  Qed.

  Lemma test0_act p e : test0 (p∙e) = test0 e.
  Proof.
    induction e;simpl;try reflexivity.
    - rewrite <-IHe1, <-IHe2;reflexivity.
    - rewrite <-IHe1, <-IHe2;reflexivity.
  Qed.

  Lemma sizeExpr_act p e : sizeExpr (p∙e) = sizeExpr e.
  Proof. unfold act;induction e;simpl; lia. Qed.

  Lemma Σ_act p L : p ∙ Σ L = Σ (p∙L).
  Proof. induction L;simpl;[|unfold act in *;rewrite <- IHL];reflexivity. Qed.

  Lemma positive_act p e : positive (p∙e) = p ∙ (positive e).
  Proof.
    induction e;simpl;replace actReg with act by reflexivity.
    - reflexivity.
    - reflexivity.
    - rewrite IHe1,IHe2;reflexivity.
    - rewrite IHe1,IHe2;reflexivity.
    - rewrite IHe;reflexivity.
    - reflexivity.
  Qed.

  Lemma KA_act p e f : e =KA f -> p ∙ e =KA p ∙ f.
  Proof.
    intro eq;induction eq.
    - reflexivity.
    - symmetry;assumption.
    - etransitivity;eassumption.
    - unfold act;simpl;replace actReg with act by reflexivity;rewrite IHeq1,IHeq2;reflexivity.
    - unfold act;simpl;replace actReg with act by reflexivity;rewrite IHeq1,IHeq2;reflexivity.
    - unfold act;simpl;replace actReg with act by reflexivity;rewrite IHeq;reflexivity.
    - destruct H;unfold act;simpl;replace actReg with act by reflexivity;apply ax_eq_ax.
      + apply KA_prod_assoc.
      + apply KA_add_assoc.
      + apply KA_add_comm.
      + apply KA_left_distr.
      + apply KA_right_distr.
      + apply KA_zero.
      + apply KA_un_left.
      + apply KA_un_right.
      + apply KA_left_zero.
      + apply KA_right_zero.
      + apply KA_idem.
      + apply KA_star_unfold.
    - destruct H as [e f|e f];unfold act;simpl;replace actReg with act by reflexivity;
        (eapply ax_eq_ax';[|apply IHeq]).
      + apply KA_star_left_ind.
      + apply KA_star_right_ind.
  Qed.

  (** * Splitting the size by name *)
  Fixpoint sizeAt e (a : atom) :=
    match e with
    | e_un | e_zero | ⟪var _⟫ => 0
    | ⟪open b⟫ | ⟪close b⟫ => if a=?=b then 1 else 0
    | e_add e f | e_prod e f => sizeAt e a + sizeAt f a
    | e_star e => sizeAt e a
    end.

  Lemma sizeAt_fresh e a : a # e -> sizeAt e a = 0.
  Proof.
    induction e;simpl;try reflexivity.
    - intros I;rewrite IHe1,IHe2.
      + reflexivity.
      + intros I';apply I,in_app_iff;now right.
      + intros I';apply I,in_app_iff;now left.
    - intros I;rewrite IHe1,IHe2.
      + reflexivity.
      + intros I';apply I,in_app_iff;now right.
      + intros I';apply I,in_app_iff;now left.
    - apply IHe.
    - destruct x;simpl;unfold_eqX;tauto.
  Qed.

  Lemma size_sizeAt e : sum (sizeAt e) {{⌊e⌋}} <= sizeExpr e.
  Proof.
    induction e;simpl;try reflexivity.
    - rewrite <- sum_add_distr;apply Plus.plus_le_compat.
      + rewrite <- IHe1;apply PeanoNat.Nat.eq_le_incl.
        symmetry;apply (sum_incr_0_right ⌊e1⌋).
        apply sizeAt_fresh.
      + rewrite <- IHe2;apply PeanoNat.Nat.eq_le_incl.
        symmetry;apply (sum_incr_0_left ⌊e2⌋).
        apply sizeAt_fresh.
    - rewrite <- sum_add_distr;apply Plus.plus_le_compat.
      + rewrite <- IHe1;apply PeanoNat.Nat.eq_le_incl.
        symmetry;apply (sum_incr_0_right ⌊e1⌋).
        apply sizeAt_fresh.
      + rewrite <- IHe2;apply PeanoNat.Nat.eq_le_incl.
        symmetry;apply (sum_incr_0_left ⌊e2⌋).
        apply sizeAt_fresh.
    - apply IHe.
    - destruct x;simpl;simpl_eqX.
      + reflexivity.
      + reflexivity.
      + rewrite sum_zero_in;[lia|intros;reflexivity].
  Qed.

End s.


Require Import ssreflect ssrbool eqtype seq.
Require Import var syntax env typing.

Definition NAT: typ := typ_tconstr 0 [::].

Definition pat_Z := pat_constr 0 [::].
Definition constr_Z := trm_constr 0 [::].
Parameter constr_typing_Z : ⊢c 0 ∈  [[::] ]⇒ NAT.

Definition pat_S p := pat_constr 1 [:: p].
Definition constr_S t := trm_constr 1 [:: t].
Parameter constr_typing_S : ⊢c 1 ∈  [[:: NAT] ]⇒ NAT.

Definition add: trm
  := trm_abs
       (Some 0) (pat_var 1)
       (trm_abs
          None (pat_var 2)
          (trm_match
             (trm_var 1)
             [:: branch_intro
                  pat_Z
                  None
                  (trm_var 2)
              ; branch_intro
                  (pat_S (pat_var 3))
                  None
                  (constr_S
                     (trm_app
                        (trm_app
                           (trm_var 0)
                           (trm_var 3))
                        (trm_var 2)))])).

Lemma typing_add: empty · empty ⊢ add ∈ NAT ⇒ NAT ⇒ NAT.
Proof.
  apply trm_typing_abs with (Δ := 1 ~ NAT);
    first by apply pat_typing_var=> //=.
  apply trm_typing_abs with (Δ := 2 ~ NAT);
    first by apply pat_typing_var=> //=.
  apply trm_typing_match with (S := NAT);
    first by apply trm_typing_var=> //=.
  repeat constructor.
  * apply branch_typing_intro with (Δ := [::]).
    - apply pat_typing_constr with (Ts := [::]);
        first by apply constr_typing_Z.
      by constructor.
    - by move=> t //.
    - by apply trm_typing_var=> //=.
  * apply branch_typing_intro with (Δ := 3 ~ NAT).
    - apply pat_typing_constr with (Ts := [:: NAT]);
        first by apply constr_typing_S.
      repeat constructor; by apply pat_typing_var=> //=.
    - by move=> t //.
    - apply trm_typing_constr with (Ts := [:: NAT]);
        first by apply constr_typing_S.
      repeat constructor.
      apply trm_typing_app with (S := NAT);
        last by apply trm_typing_var=> //=.
      apply trm_typing_app with (S := NAT);
        last by apply trm_typing_var=> //=.
      apply trm_typing_var=> //=.
Qed.

Definition LISTBOOL: typ := typ_tconstr 1 [::].

Definition pat_Nil := pat_constr 2 [::].
Definition constr_Nil := trm_constr 2 [::].
Parameter constr_typing_Nil : ⊢c 2 ∈  [[::] ]⇒ LISTBOOL.

Definition pat_Cons pa ps := pat_constr 3 [:: pa ; ps].
Definition constr_Cons a t := trm_constr 3 [:: a ; t].
Parameter constr_typing_Cons : ⊢c 3 ∈  [[:: BOOL ; LISTBOOL] ]⇒ LISTBOOL.

Definition lifting_add: trm
  := trm_abs
       (Some 0) (pat_var 1)
       (trm_abs
          None (pat_var 2)
          (trm_match
             (trm_var 1)
             [:: branch_intro
                  pat_Nil
                  None
                  (trm_var 2)
              ; branch_intro
                  (pat_Cons (pat_var 4) (pat_var 3))
                  None
                  (constr_Cons
                     (trm_metavar 0 [:: trm_var 4; trm_var 3; trm_var 2; trm_var 1; trm_var 0 ])
                     (trm_app
                        (trm_app
                           (trm_var 0)
                           (trm_var 3))
                        (trm_var 2)))])).

Lemma typing_lifting_add:
  (0 ~ ([:: BOOL ; LISTBOOL ; LISTBOOL ; LISTBOOL ; LISTBOOL ⇒ LISTBOOL ⇒ LISTBOOL ] , BOOL)) · empty ⊢ lifting_add ∈ LISTBOOL ⇒ LISTBOOL ⇒ LISTBOOL.
Proof.
  apply trm_typing_abs with (Δ := 1 ~ LISTBOOL);
    first by apply pat_typing_var=> //=.
  apply trm_typing_abs with (Δ := 2 ~ LISTBOOL);
    first by apply pat_typing_var=> //=.
  apply trm_typing_match with (S := LISTBOOL);
    first by apply trm_typing_var=> //=.
  repeat constructor.
  * apply branch_typing_intro with (Δ := [::]).
    - apply pat_typing_constr with (Ts := [::]);
        first by apply constr_typing_Nil.
      by constructor.
    - by move=> t //.
    - by apply trm_typing_var=> //=.
  * apply branch_typing_intro with (Δ := 4 ~ BOOL & 3 ~ LISTBOOL).
    - apply pat_typing_constr with (Ts := [:: BOOL ; LISTBOOL]);
        first by apply constr_typing_Cons.
      by repeat constructor.
    - by move=> t //.
    - apply trm_typing_constr with (Ts := [:: BOOL ; LISTBOOL]);
        first by apply constr_typing_Cons.
      repeat constructor.
      eapply trm_typing_metavar=> //=;
        by repeat constructor.
      apply trm_typing_app with (S := LISTBOOL);
        last by apply trm_typing_var=> //=.
      apply trm_typing_app with (S := LISTBOOL);
        last by apply trm_typing_var=> //=.
      apply trm_typing_var=> //=.
Qed.

Definition admitted {X}: X. admit. Qed.

Definition lookup (Γ: env)(x: var)(T: typ): option (Γ ⊢ trm_var x ∈ T).
 refine ((match get x Γ
                as o'
                return (get x Γ = o' -> option (Γ ⊢ trm_var x ∈ T))
      with
        | None => (fun _ => None)
        | Some T' =>
          (match T == T' as b
                return (T == T' = b -> get x Γ = Some T' -> option (Γ ⊢ trm_var x ∈ T)) with
            | false => (fun _ _ => None)
            | true => (fun q1 q2 => Some (trm_typing_var _ _ _ _))
           end) Logic.eq_refl
          end) Logic.eq_refl).
move/eqP: q1=> [->]; done.
Defined.

Fixpoint check (Γ: env)(t: trm)(T: typ) : option (Γ ⊢ t ∈ T) :=
  match t return option (Γ ⊢ t ∈ T) with
    | trm_var x =>
      lookup Γ x T
    | _ => None
  end.

Fixpoint lift {Γ t T} (d: Γ ⊢ t ∈ T): orn T -> trm
  :=

  | trm_cst : cst -> trm
  | trm_abs : option var -> pat -> trm -> trm
  | trm_constr : constr -> seq trm -> trm
  | trm_unary : prim -> trm -> trm
  | trm_binary : prim -> trm -> trm -> trm
  | trm_app : trm -> trm -> trm
  | trm_seq : trm -> trm -> trm
  | trm_let : pat -> trm -> trm -> trm
  | trm_if : trm -> trm -> option trm -> trm
  | trm_match : trm -> seq branch -> trm
with branch : Type :=
  | branch_intro : pat -> option trm -> trm -> branch.


Require Import ProofIrrelevance.
Require Export SigTInducedFunctors SigTSigCategory.
Require Import Common FEqualDep.

Set Implicit Arguments.

Generalizable All Variables.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Section T2.
  (* use dummy variables so we don't have to specify the types of
     all these hypotheses *)
  Context `(dummy0 : @SpecializedCategory_sigT_sig objA A Pobj0 Pmor0 Pidentity0 Pcompose0).
  Context `(dummy1 : @SpecializedCategory_sigT_sig objA A Pobj1 Pmor1 Pidentity1 Pcompose1).

  Let sigT_sig_cat0 := @SpecializedCategory_sigT_sig objA A Pobj0 Pmor0 Pidentity0 Pcompose0.
  Let sigT_sig_cat1 := @SpecializedCategory_sigT_sig objA A Pobj1 Pmor1 Pidentity1 Pcompose1.

  Variable P_ObjectOf : forall x, Pobj0 x -> Pobj1 x.

  Let InducedT2Functor_sigT_sig_ObjectOf (x : sigT Pobj0) : sigT Pobj1
    := existT _ (projT1 x) (P_ObjectOf (projT2 x)).

  Hypothesis P_MorphismOf : forall (s d : sigT Pobj0) (m : sig (Pmor0 s d)),
    Pmor1
    (existT Pobj1 (projT1 s) (P_ObjectOf (projT2 s)))
    (existT Pobj1 (projT1 d) (P_ObjectOf (projT2 d)))
    (proj1_sig m).

  Let InducedT2Functor_sigT_sig_MorphismOf (s d : sigT Pobj0) (m : sig (Pmor0 s d)) :
    sig (Pmor1 (InducedT2Functor_sigT_sig_ObjectOf s) (InducedT2Functor_sigT_sig_ObjectOf d))
    := exist _ (proj1_sig m) (@P_MorphismOf s d m).

  Let sig_of_sigT' (A : Type) (P : A -> Prop) (X : sigT P) := exist P (projT1 X) (projT2 X).
  Let sigT_of_sig' (A : Type) (P : A -> Prop) (X : sig P) := existT P (proj1_sig X) (proj2_sig X).

  Definition InducedT2Functor_sigT_sig : SpecializedFunctor sigT_sig_cat0 sigT_sig_cat1.
    eapply (ComposeFunctors (sigT_functor_sigT_sig _ _ _ _) (ComposeFunctors _ (sigT_sig_functor_sigT _ _ _ _))).
    Grab Existential Variables.
    eapply (@InducedT2Functor_sigT _ A Pobj0 Pmor0 Pidentity0 Pcompose0 _ _ _ Pobj1 Pmor1 Pidentity1 Pcompose1 _ _ _
      P_ObjectOf (fun s d m => @P_MorphismOf s d (sig_of_sigT' m)));
    subst_body;
    abstract (simpl; intros; apply proof_irrelevance).
  Defined.
End T2.


(* ############################################################ *)
(*                                                              *)
(*               Language definition for STLC 1/2               *)
(*                                                              *)
(* ############################################################ *)

(* Starting point: https://github.com/TiarkRompf/minidot/blob/master/dev2015/nano2.v *)
(* Starting point: https://github.com/TiarkRompf/scala-escape/blob/master/coq/stlc1.v *)

Require Export Arith.EqNat.
Require Export Arith.Le.
From Coq Require Import omega.Omega.
Require Import Coq.Lists.List.

Import ListNotations.

(* ############################################################ *)
(* Definitions                                                  *)
(* ############################################################ *)

(* ### Syntax ### *)

Definition id := nat.

Inductive class : Type :=
  | First  : class
  | Second : class
.

(* types *)
Inductive ty : Type :=
  | TBool  : ty
  | TFun   : ty -> class -> ty -> ty
  | TRec   : ty -> ty (* NEW: wrapper indicates recursive occurrence *)
  | TCap   : ty      (* NEW: capability to unwrap TRec values *)
.

(* variables: 1st or 2nd class, using DeBrujin levels *)
Inductive var : Type :=
  | V : class -> id -> var
.

(* terms *)
Inductive tm : Type :=
  | ttrue  : tm
  | tfalse : tm
  | tvar   : var -> tm
  | tapp   : tm -> tm -> tm     (* f(x) *)
  | tabs   : class -> tm -> tm  (* \f x.y *)
  | tunrec : tm -> tm -> tm     (* NEW: unwrap a recursive value, given a capability *)
.

(* environments, split according to 1st/2nd class *)
Inductive env (X: Type) :=
  | Def : list X -> list X -> nat -> env X.

(* values *)
Inductive vl : Type :=
  | vbool : bool -> vl
  | vabs  : env vl -> class -> tm -> vl
  | vrec  : vl -> vl (* NEW: recursive wrapper *)
  | vcap  : vl      (* NEW: capability *)
.

Definition venv := env vl.  (* value environments *)
Definition tenv := env ty.  (* type environments  *)

Hint Unfold venv.
Hint Unfold tenv.

Fixpoint ble_nat (n m : nat) : bool :=
  match n with
  | O => true
  | S n' =>
      match m with
      | O => false
      | S m' => ble_nat n' m'
      end
  end.

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

Definition lookup {X : Type} (n : var) (l : env X) : option X :=
  match l with
    | Def _ l1 l2 m =>
         match n with
           | V First idx  => index idx l1
           | V Second idx => if ble_nat m idx then index idx l2 else None
         end
   end
.

(* restrict visible bindings in environment *)
Definition sanitize_any {X : Type} (l : env X) (n:nat): env X :=
  match l with
    | Def _ l1 l2 _ => Def X l1 l2 n
  end.

Definition sanitize_env {X : Type} (c : class) (l : env X) : env X :=
  match c,l  with
    | First, Def _ _ l2 _ => sanitize_any l (length l2)
    | Second, _ => l
  end.

(* add new binding to environment *)
Definition expand_env {X : Type} (l : env X) (x : X) (c : class) : (env X) :=
match l with
| Def _ l1 l2 m =>
   match c with
   | First => Def X (x::l1) l2 m
   | Second => Def X l1 (x::l2) m
   end
end
.

(* ### Type Assignment ### *)

Inductive has_type : tenv -> tm -> class -> ty -> Prop :=
| t_true: forall n env,
           has_type env ttrue n TBool
| t_false: forall n env,
           has_type env tfalse n TBool
| t_var: forall n x env T1,
           lookup x (sanitize_env n env) = Some T1 ->
           has_type env (tvar x) n T1
| t_app: forall m n env f x T1 T2,
           has_type env f Second (TFun T1 m T2) ->
           has_type env x m T1 ->
           has_type env (tapp f x) n T2
| t_abs: forall m n env y T1 T2,  (* NEW: wrap recursive binding *)
           has_type (expand_env (expand_env (sanitize_env n env) (TRec (TFun T1 m T2)) Second) T1 m) y First T2 ->
           has_type env (tabs m y) n (TFun T1 m T2)
| t_unrec: forall n env tr tc T1, (* NEW: unrec case *)
           has_type env tr n (TRec T1) ->
           has_type env tc n TCap ->
           has_type env (tunrec tr tc) n T1
.

Definition get_inv_idx {X : Type} (env : env X) :=
match env with
| Def _ l1 l2 idx => idx
end
.

(* ### Operational Semantics ### *)

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

Fixpoint teval(k: nat)(env: venv)(t: tm)(n: class){struct k}: option (option vl) :=
  match k with
    | 0 => None
    | S k' =>
      match t with
        | ttrue      => Some (Some (vbool true))
        | tfalse     => Some (Some (vbool false))
        | tvar x     => Some (lookup x (sanitize_env n env))
        | tabs m y   => Some (Some (vabs (sanitize_env n env) m y))
        | tapp ef ex   =>
           match teval k' env ef Second with
             | None => None
             | Some None => Some None
             | Some (Some (vbool _)) => Some None
             | Some (Some (vrec _)) => Some None (* NEW *)
             | Some (Some vcap) => Some None (* NEW *)
             | Some (Some (vabs env2 m ey)) => (* NEW: vrec wrapper *)
                match teval k' env ex m with
                  | None => None
                  | Some None => Some None
                  | Some (Some vx) =>
                       teval k' (expand_env (expand_env env2 (vrec (vabs env2 m ey)) Second) vx m) ey First
                end
           end
        | tunrec er ec => (* NEW *)
          match teval k' env er n with
          | None => None
          | Some None => Some None
          | Some (Some (vbool _)) => Some None
          | Some (Some (vabs _ _ _)) => Some None
          | Some (Some vcap) => Some None
          | Some (Some (vrec v)) =>
            match teval k' env ec n with (* should use Second instead of n? *)
            | None => None
            | Some None => Some None
            | Some (Some (vbool _)) => Some None
            | Some (Some (vabs _ _ _)) => Some None
            | Some (Some (vrec _)) => Some None
            | Some (Some vcap) =>
              Some (Some v)
            end
          end
      end
  end.

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

(* ### Some helper lemmas ### *)

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

Hint Constructors has_type.

Hint Constructors option.
Hint Constructors list.
Hint Constructors env.

Hint Unfold index.
Hint Unfold length.
Hint Unfold expand_env.
Hint Unfold lookup.
Hint Unfold index.
Hint Unfold sanitize_env.
Hint Unfold sanitize_any.

Hint Resolve ex_intro.

Definition length_env {X : Type} (c : class) (env : env X): nat :=
match env, c with
| Def _ l1 l2 n, First => length l1
| Def _ l1 l2 n, Second => length l2
end
.

Definition get_class (x : var): class :=
match x with
| V c _ => c
end
.

Definition get_idx (x : var): nat :=
match x with
| V _ n => n
end
.

Lemma index_max : forall X vs n (T: X),
                       index n vs = Some T ->
                       n < length vs.
Proof.
  intros X vs. induction vs.
  - (* nil *) intros. inversion H.
  - (* case *) intros. inversion H.
    case_eq (beq_nat n (length vs)); intros E.
    + (* SCase "hit". *)
      rewrite E in H1. inversion H1. subst.
      eapply beq_nat_true in E.
      unfold length. unfold length in E. rewrite E. eauto.
    + (* SCase "miss". *)
      rewrite E in H1.
      assert (n < length vs). eapply IHvs. apply H1.
      compute. eauto.
Qed.

Hint Immediate index_max.

Lemma lookup_max : forall X vs x (T: X),
                       lookup x vs = Some T ->
                       get_idx x < length_env (get_class x) vs.
Proof.
  intros X vs; destruct vs as [l1 l2 n].
  intros x T H.
  destruct x. destruct c; simpl.
  - (* Case "VFst". *) inversion H; eauto.
  - (* Case "VSnd". *) inversion H.
    destruct (ble_nat n i); inversion H1; eauto.
Qed.

(* ############################################################ *)
(*                                                              *)
(*                 Type soundness for STLC 1/2                  *)
(*                                                              *)
(* ############################################################ *)

Theorem ex_falso_quodlibet : forall (P:Prop),
  False -> P.
Proof.
  intros P contra.
  inversion contra.
Qed.

(* ############################################################ *)
(* Definitions                                                  *)
(* ############################################################ *)

(* ### Value typing and well-typed runtime environments ### *)

Inductive wf_env : venv -> tenv -> Prop :=
| wfe_nil : forall n, wf_env (Def vl nil nil n) (Def ty nil nil n)
| wfe_cons : forall v t vs ts n,
    val_type (expand_env vs v n) v t ->
    wf_env vs ts ->
    get_inv_idx vs = get_inv_idx ts ->
    wf_env (expand_env vs v n) (expand_env ts t n)

with val_type : venv -> vl -> ty -> Prop :=
| v_bool: forall venv b,
    val_type venv (vbool b) TBool
| v_abs: forall env venv tenv y T1 T2 m, (* NEW: TRec wrapper *)
    wf_env venv tenv ->
    has_type (expand_env (expand_env tenv (TRec (TFun T1 m T2)) Second) T1 m) y First T2 ->
    val_type env (vabs venv m y) (TFun T1 m T2)
| v_rec: forall env v T,  (* NEW *)
    val_type env v T ->
    val_type env (vrec v) (TRec T)
| v_cap: forall env,
    val_type env vcap TCap (* NEW *)
.

(* type equivalence: only via reflexivity *)
Inductive stp: venv -> ty -> venv -> ty -> Prop :=
| stp_refl: forall G1 G2 T,
   stp G1 T G2 T.

Hint Constructors val_type.
Hint Constructors wf_env.

Hint Unfold expand_env.

Lemma length_env_incr : forall (X : Type) n m env (x : X),
   n = m ->
   length_env n (expand_env env x m) = 1 + length_env n env.
Proof.
  intros. destruct env0; destruct n; inversion H; auto.
Qed.

Lemma length_env_same : forall (X : Type) n m env (x : X),
   n <> m ->
   length_env n (expand_env env x m) = length_env n env.
Proof.
  intros. destruct env0; destruct n; destruct m.
      apply ex_falso_quodlibet; auto.
      auto.
      auto.
      apply ex_falso_quodlibet; auto.
Qed.

Hint Rewrite length_env_incr.
Hint Rewrite length_env_same.
Hint Unfold not.

Lemma wf_length : forall vs ts,
      wf_env vs ts ->
      length_env First vs = length_env First ts /\ length_env Second vs = length_env Second ts.
Proof.
  intros. induction H; auto.
  destruct IHwf_env as [L R].
  destruct n.
  - (* Case "First" *) split.
    repeat rewrite length_env_incr; auto.
    repeat rewrite length_env_same; auto.
    unfold not; intros. inversion H2. unfold not; intros. inversion H2.
  - (* Case "Second" *) split.
    repeat rewrite length_env_same; auto.
    unfold not; intros. inversion H2. unfold not; intros. inversion H2.
    repeat rewrite length_env_incr; auto.
Qed.

Hint Immediate wf_length.

Lemma wf_idx : forall vs ts,
      wf_env vs ts ->
      get_inv_idx vs = get_inv_idx ts.
Proof.
  intros. induction H; auto.
  destruct vs; destruct ts; destruct n; auto.
Qed.

Hint Immediate wf_idx.

Lemma valtp_extend : forall vs v v1 T n,
                       val_type vs v T ->
                       val_type (expand_env vs v1 n) v T.
Proof. intros. induction H; eauto. Qed.

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

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

Hint Immediate index_extend.

Lemma lookup_extend : forall X vs x a (T: X) n,
                       lookup x vs = Some T ->
                       lookup x (expand_env vs a n) = Some T.

Proof.
  intros.
  assert (get_idx x < length_env (get_class x) vs). eapply lookup_max. eauto.
  assert (get_idx x <> length_env (get_class x) vs). omega.
  assert (beq_nat (get_idx x) (length_env (get_class x) vs) = false) as E. eapply beq_nat_false_iff; eauto.
  destruct vs.
  destruct n; destruct x; destruct c; simpl in E;
    inversion H; simpl; try rewrite E; auto.
Qed.

(*
Lemma index_safe_ex: forall Hl1 Hl2 Gl1 Gl2 Hidx Gidx TF i,
   wf_env (Def vl Hl1 Hl2 Hidx) (Def ty Gl1 Gl2 Gidx) ->
   index i Gl1 = Some TF ->
   exists v, index i Hl1 = Some v.
Proof. intros.
  apply wf_length in H. destruct H as [L _]. simpl in L.

Qed.
*)

Lemma lookup_safe_ex: forall H1 G1 TF x,
             wf_env H1 G1 ->
             lookup x G1 = Some TF ->
             exists v, lookup x H1 = Some v /\ val_type H1 v TF.
Proof. intros. induction H.
  - (* Case "nil". *) inversion H0. destruct x; destruct c; destruct (ble_nat n i); inversion H1.
  - (* Case "cons". *) destruct vs as [vl1 vl2 vidx]. destruct ts as [tl1 tl2 tidx].
    apply wf_length in H1. destruct H1 as [H1l H1r].
    destruct x; destruct c; inversion H0.
    + (* SCase "VFst". *) destruct n; simpl in H0 ; simpl in H2.
      * (* SSCase "First". *)
        case_eq (beq_nat i (length tl1)).
        { (* SSSCase "hit". *)
          intros E.
          rewrite E in H0. inversion H0. subst t. simpl.
          assert (beq_nat i (length vl1) = true). eauto.
          rewrite H1. eauto. }
        { (* SSSCase "miss". *)
          intros E.
          assert (beq_nat i (length vl1) = false). eauto.
          assert (exists v0, lookup (V First i) (Def vl vl1 vl2 vidx) = Some v0 /\ val_type (Def vl vl1 vl2 vidx) v0 TF) as HI.
          eapply IHwf_env. simpl. rewrite E in H0. eauto.
          inversion HI as [v0 HI1]. inversion HI1.
          eexists. econstructor. eapply lookup_extend; eauto. eapply valtp_extend; eauto. }
     * (* SSCase "Second". *)
       assert (exists v0, lookup (V First i) (Def vl vl1 vl2 vidx) = Some v0 /\ val_type (Def vl vl1 vl2 vidx) v0 TF) as HI.
       eapply IHwf_env. simpl. eauto.
       inversion HI as [v0 HI1]. inversion HI1.
       eexists. econstructor. eapply lookup_extend; eauto. eapply valtp_extend; eauto.
   + (* SCase "VSnd". *) destruct n; simpl in H0; simpl in H2.
     * (* SSCase "First". *)
       assert (exists v0, lookup (V Second i) (Def vl vl1 vl2 vidx) = Some v0 /\ val_type (Def vl vl1 vl2 vidx) v0 TF) as HI.
       eapply IHwf_env. simpl. eauto.
       inversion HI as [v0 HI1]. inversion HI1.
       eexists. econstructor. eapply lookup_extend; eauto. eapply valtp_extend; eauto.
     * (* SSCase "Second". *)
       case_eq (beq_nat i (length tl2)).
        { (* SSSCase "hit". *)
          intro E.
          rewrite E in H0. simpl. destruct (ble_nat tidx i); inversion H0.
          subst t.
          assert (beq_nat i (length vl2) = true). eauto.
          rewrite H1. inversion H3. subst vidx. destruct (ble_nat tidx i); eauto. inversion H5. }
        { (* SSSCase "miss". *)
          intro E.
          assert (beq_nat i (length vl2) = false). eauto.
          assert (exists v0, lookup (V Second i) (Def vl vl1 vl2 vidx) = Some v0 /\ val_type (Def vl vl1 vl2 vidx) v0 TF) as HI.
          eapply IHwf_env. simpl. destruct (ble_nat tidx i). inversion H0. rewrite E in H0. rewrite H0. rewrite E. auto. auto.
          inversion HI as [v0 HI1]. inversion HI1.
          eexists. econstructor. eapply lookup_extend; eauto. eapply valtp_extend; eauto. }
Qed.

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

Hint Constructors res_type.
Hint Resolve not_stuck.

Lemma valtp_widen: forall vf H1 H2 T1 T2,
  val_type H1 vf T1 ->
  stp H1 T1 H2 T2 ->
  val_type H2 vf T2.
Proof.
  intros. generalize dependent T2. induction H; intros.
  - inversion H0. eauto.
  - inversion H1. eauto.
  - inversion H0. eapply v_rec. eapply IHval_type. eapply stp_refl.
  - inversion H0. eauto.
Qed.

Lemma invert_abs: forall venv vf vx T1 n T2,
  val_type venv vf (TFun T1 n T2) ->
  exists env tenv y T3 T4,
    vf = (vabs env n y) /\
    wf_env env tenv /\
    has_type (expand_env (expand_env tenv (TRec (TFun T3 n T4)) Second) T3 n) y First T4 /\
    stp venv T1 (expand_env (expand_env env (vrec vf) Second) vx n) T3 /\
    stp (expand_env (expand_env env (vrec vf) Second) vx n) T4 venv T2.
Proof.
  intros. inversion H. repeat eexists; repeat eauto.
Qed.

Lemma ext_sanitize_commute : forall {T} n venv (v:T) c,
   expand_env (sanitize_any venv n) v c = sanitize_any (expand_env venv v c) n.
Proof.
  intros. destruct venv0. destruct c; simpl; eauto.
Qed.

Lemma val_type_sanitize_any : forall n venv res T,
  val_type venv res T ->
  val_type (sanitize_any venv n) res T.
Proof.
  intros. induction H; eauto.
Qed.

Lemma val_type_sanitize : forall env res T n,
  val_type (sanitize_env n env) res T ->
  val_type env res T.
Proof.
  intros. induction H; eauto.
Qed.

Lemma wf_sanitize_any : forall n venv tenv,
   wf_env venv tenv ->
   wf_env (sanitize_any venv n) (sanitize_any tenv n).
Proof.
  intros. induction H.
  - simpl. eapply wfe_nil.
  - eapply wfe_cons in IHwf_env.
    rewrite <-ext_sanitize_commute. rewrite <-ext_sanitize_commute.
    eauto. eauto. rewrite ext_sanitize_commute.
    eapply val_type_sanitize_any in H. eauto. eauto.
Qed.

Lemma wf_sanitize : forall n venv tenv,
   wf_env venv tenv ->
   wf_env (sanitize_env n venv) (sanitize_env n tenv).
Proof.
  intros. destruct n; unfold sanitize_env. destruct venv0. destruct tenv0.
  assert (length l0 = length l2). apply wf_length in H; destruct H as [L R]; eauto.
  rewrite H0. eapply wf_sanitize_any. eauto.
  eauto.
Qed.

Hint Immediate wf_sanitize.

(* ### Theorem 3.5 ### *)
(* if result of STLC 1/2 evaluation is not a timeout, then *)
(* it is not stuck, and well-typed *)

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

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

  - (* Case "True". *)  eapply not_stuck. eapply v_bool.
  - (* Case "False". *) eapply not_stuck. eapply v_bool.

  - (* Case "Var". *)
    subst.
    destruct (lookup_safe_ex (sanitize_env n venv0) (sanitize_env n tenv0) T v) as [va [I V]]; eauto.

    rewrite I. eapply not_stuck. eapply val_type_sanitize. eapply V.

  - (* Case "App". *)
    remember (teval k venv0 e1 Second) as tf.
    subst T. subst n0.

    destruct tf as [rf|]; try inversion H3.
    assert (res_type venv0 rf (TFun T1 m T2)) as HRF. (* SCase "HRF". *) subst. eapply IHk; eauto.
    inversion HRF as [? vf].

    subst rf. remember vf as rvf. destruct vf; subst rvf; inversion H7. (* try (subst rvf; solve inversion). *)
    assert (c = m). destruct m; destruct c; try inversion H18; eauto. (* try (subst rvf; solve inversion); eauto.*) subst c. (* subst rvf. *)
    remember (teval k venv0 e2 m0) as tx.

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

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

    inversion EF. subst e. subst y0. clear EF.
    subst rx.

    assert (res_type (expand_env (expand_env env1' (vrec (vabs venv2 m t)) Second) vx m) res T4') as HRY.
        (* SSSCase "HRY". *)
          subst. eapply IHk; eauto.
        (* wf_env f x *) econstructor. eapply valtp_widen; eauto.
        (* wf_env f   *) econstructor. eapply v_rec. eapply v_abs; eauto.
          eauto.
          apply wf_idx. assumption.
          apply wf_idx. econstructor. eauto. assumption. apply wf_idx. assumption.

    inversion HRY as [? vy].

    eapply not_stuck. eapply valtp_widen; eauto.

  - (* Case "Abs". *) intros. inversion H. inversion H0.
    eapply not_stuck. eapply v_abs; eauto.
    eauto.
  - (* Case "Rec". *)
    remember (teval k venv0 e1 n) as tevr.

    destruct tevr as [revr|]; try inversion H3.
    assert (res_type venv0 revr (TRec T)) as HRR. {
     subst. eapply IHk; eauto.
    }

    inversion HRR as [? vr]. inversion H10. subst.

    remember (teval k venv0 e2 n) as tevc.
    destruct tevc as [revc|]; try inversion H11.
    assert (res_type venv0 revc TCap) as HRC. {
      subst. eapply IHk; eauto.
    }
    inversion HRC as [? vc]. inversion H2. subst.
    (* NOTE: if there is no val_type case for vcap this inversion fails
    and recursion is impossible in well-formed envs *)

    inversion H4. subst. eauto.
Qed.

(* Strong Normalization for STLC *)

(* copied from nano0.v *)
(* copied from dev2017/nano0-total.v *)

(* This version prohibits recursion, and we prove that   *)
(* evaluation always terminates with a well-typed value. *)
(* From this follows both type soundness and strong      *)
(* normalization for STLC.                               *)

Definition tevaln env e cl v := exists nm, forall n, n > nm -> teval n env e cl = Some (Some v).

(* need to use Fixpoint because of positivity restriction *)
Fixpoint val_type_tnt (env:venv) (v:vl) (T:ty): Prop := match v, T with
| vbool b, TBool => True
| vabs env clv y, TFun T1 clt T2 => (clv = clt) /\
  (forall vx, val_type_tnt env vx T1 ->
     exists v, tevaln (expand_env (expand_env env (vrec (vabs env clv y)) Second) vx clv) y First v /\ val_type_tnt env v T2)
| vrec v, TRec T => True (* NEW: rec, but we can't do anything with it *)
| _,_ => False
end.

Inductive wf_env_tnt : venv -> tenv -> Prop :=
| wfe_tnt_nil : forall n, wf_env_tnt (Def vl nil nil n) (Def ty nil nil n)
| wfe_tnt_env : forall v t vs ts n,
    val_type_tnt (expand_env vs v n) v t ->
    (* val_type (expand_env vs v n) v t ?? *) (* vrec v ?? *)
    wf_env_tnt vs ts ->
    get_inv_idx vs = get_inv_idx ts ->
    wf_env_tnt (expand_env vs v n) (expand_env ts t n)
.

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

Hint Constructors has_type.
(* Hint Constructors val_type. *)
Hint Constructors wf_env_tnt.

Hint Constructors option.
Hint Constructors list.

Hint Unfold index.
Hint Unfold length.

Hint Resolve ex_intro.

Lemma wf_length_tnt : forall vs ts,
      wf_env_tnt vs ts ->
      length_env First vs = length_env First ts /\ length_env Second vs = length_env Second ts.
Proof.
  intros. induction H; auto.
  destruct IHwf_env_tnt as [L R].
  destruct n.
  - (* Case "First" *) split.
    repeat rewrite length_env_incr; auto.
    repeat rewrite length_env_same; auto.
    unfold not; intros. inversion H2. unfold not; intros. inversion H2.
  - (* Case "Second" *) split.
    repeat rewrite length_env_same; auto.
    unfold not; intros. inversion H2. unfold not; intros. inversion H2.
    repeat rewrite length_env_incr; auto.
Qed.

Hint Immediate wf_length_tnt.

Lemma valtp_extend_tnt : forall vs v v1 T n,
                       val_type_tnt vs v T ->
                       val_type_tnt (expand_env vs v1 n) v T.
Proof.
  intros. induction v; destruct T; try (simpl in H; inversion H); auto.
Qed.

(* NOTE: will needed (closed T vs) ! *)
Lemma valtp_shrink_tnt : forall vs v v1 T n,
                       val_type_tnt (expand_env vs v1 n) v T ->
                       val_type_tnt vs v T.
Proof.
  intros. induction v; destruct T; try (simpl in H; inversion H); auto.
Qed.

Lemma lookup_safe_ex_tnt: forall H1 G1 TF x,
             wf_env_tnt H1 G1 ->
             lookup x G1 = Some TF ->
             exists v, lookup x H1 = Some v /\ val_type_tnt H1 v TF.
Proof. intros. induction H.
  - (* Case "nil". *) inversion H0. destruct x; destruct c; destruct (ble_nat n i); inversion H1.
  - (* Case "cons". *) destruct vs as [vl1 vl2 vidx]. destruct ts as [tl1 tl2 tidx].
    apply wf_length_tnt in H1. destruct H1 as [H1l H1r].
    destruct x; destruct c; inversion H0.
    + (* SCase "VFst". *) destruct n; simpl in H0 ; simpl in H2.
      * (* SSCase "First". *)
        case_eq (beq_nat i (length tl1)).
        { (* SSSCase "hit". *)
          intros E.
          rewrite E in H0. inversion H0. subst t. simpl.
          assert (beq_nat i (length vl1) = true). eauto.
          rewrite H1. eauto. }
        { (* SSSCase "miss". *)
          intros E.
          assert (beq_nat i (length vl1) = false). eauto.
          assert (exists v0, lookup (V First i) (Def vl vl1 vl2 vidx) = Some v0 /\ val_type_tnt (Def vl vl1 vl2 vidx) v0 TF) as HI.
          eapply IHwf_env_tnt. simpl. rewrite E in H0. eauto.
          inversion HI as [v0 HI1]. inversion HI1.
          eexists. econstructor. eapply lookup_extend; eauto. eapply valtp_extend_tnt; eauto. }
     * (* SSCase "Second". *)
       assert (exists v0, lookup (V First i) (Def vl vl1 vl2 vidx) = Some v0 /\ val_type_tnt (Def vl vl1 vl2 vidx) v0 TF) as HI.
       eapply IHwf_env_tnt. simpl. eauto.
       inversion HI as [v0 HI1]. inversion HI1.
       eexists. econstructor. eapply lookup_extend; eauto. eapply valtp_extend_tnt; eauto.
   + (* SCase "VSnd". *) destruct n; simpl in H0; simpl in H2.
     * (* SSCase "First". *)
       assert (exists v0, lookup (V Second i) (Def vl vl1 vl2 vidx) = Some v0 /\ val_type_tnt (Def vl vl1 vl2 vidx) v0 TF) as HI.
       eapply IHwf_env_tnt. simpl. eauto.
       inversion HI as [v0 HI1]. inversion HI1.
       eexists. econstructor. eapply lookup_extend; eauto. eapply valtp_extend_tnt; eauto.
     * (* SSCase "Second". *)
       case_eq (beq_nat i (length tl2)).
        { (* SSSCase "hit". *)
          intro E.
          rewrite E in H0. simpl. destruct (ble_nat tidx i); inversion H0.
          subst t.
          assert (beq_nat i (length vl2) = true). eauto.
          rewrite H1. inversion H3. subst vidx. destruct (ble_nat tidx i); eauto. inversion H5. }
        { (* SSSCase "miss". *)
          intro E.
          assert (beq_nat i (length vl2) = false). eauto.
          assert (exists v0, lookup (V Second i) (Def vl vl1 vl2 vidx) = Some v0 /\ val_type_tnt (Def vl vl1 vl2 vidx) v0 TF) as HI.
          eapply IHwf_env_tnt. simpl. destruct (ble_nat tidx i). inversion H0. rewrite E in H0. rewrite H0. rewrite E. auto. auto.
          inversion HI as [v0 HI1]. inversion HI1.
          eexists. econstructor. eapply lookup_extend; eauto. eapply valtp_extend_tnt; eauto. }
Qed.

Lemma val_type_tnt_env_change: forall venv0 venv1 v T,
    val_type_tnt venv0 v T <-> val_type_tnt venv1 v T.
Proof.
  split; destruct v; destruct T; auto.
Qed.

Lemma invert_abs_tnt: forall venv vf T1 cl T2,
  val_type_tnt venv vf (TFun T1 cl T2) ->
  exists env y,
    vf = (vabs env cl y) /\
    (forall vx, val_type_tnt venv vx T1 ->
       exists v, tevaln (expand_env (expand_env env (vrec vf) Second) vx cl) y First v /\ val_type_tnt venv v T2).
Proof.
  intros. simpl in H. destruct vf.
  - inversion H.
  - destruct H. subst c. exists e. exists t. split. eauto. intros.
    apply (val_type_tnt_env_change venv0 e vx T1) in H. destruct (H0 vx H) as [v [H2 H3]].
    exists v. split. auto. apply (val_type_tnt_env_change venv0 e v T2). auto.
  - inversion H.
  - inversion H.
Qed.

Lemma val_type_sanitize_any_tnt : forall n venv res T,
  val_type_tnt venv res T ->
  val_type_tnt (sanitize_any venv n) res T.
Proof.
  intros. induction res; destruct T; try (simpl in H; inversion H); auto.
Qed.

Lemma val_type_sanitize_tnt : forall env res T n,
  val_type_tnt (sanitize_env n env) res T ->
  val_type_tnt env res T.
Proof.
  intros. induction res; destruct T; try (simpl in H; inversion H); auto.
Qed.

Lemma wf_idx_tnt : forall vs ts,
      wf_env_tnt vs ts ->
      get_inv_idx vs = get_inv_idx ts.
Proof.
  intros. induction H; auto.
  destruct vs; destruct ts; destruct n; auto.
Qed.

Hint Immediate wf_idx_tnt.

Lemma wf_sanitize_any_tnt : forall n venv tenv,
   wf_env_tnt venv tenv ->
   wf_env_tnt (sanitize_any venv n) (sanitize_any tenv n).
Proof.
  intros. induction H.
  - simpl. eapply wfe_tnt_nil.
  - eapply wfe_tnt_env in IHwf_env_tnt.
    rewrite <-ext_sanitize_commute. rewrite <-ext_sanitize_commute.
    eauto. eauto. rewrite ext_sanitize_commute.
    eapply val_type_sanitize_any_tnt in H. eauto. eauto.
Qed.

Lemma wf_sanitize_tnt : forall n venv tenv,
   wf_env_tnt venv tenv ->
   wf_env_tnt (sanitize_env n venv) (sanitize_env n tenv).
Proof.
  intros. destruct n; unfold sanitize_env. destruct venv0. destruct tenv0.
  assert (length l0 = length l2). apply wf_length_tnt in H; destruct H as [L R]; eauto.
  rewrite H0. eapply wf_sanitize_any_tnt. eauto.
  eauto.
Qed.

Hint Immediate wf_sanitize_tnt.

(* if well-typed, then result is an actual value (not stuck and not a timeout),
   for large enough n *)

Theorem full_total_safety : forall e cl tenv T,
  has_type tenv e cl T -> forall venv, wf_env_tnt venv tenv ->
  exists v, tevaln venv e cl v /\ val_type_tnt venv v T.

Proof.
  intros ? ? ? ? W.
  induction W; intros ? WFE.

  - (* Case "True". *) eexists. split.
    exists 0. intros. destruct n0. omega. simpl. eauto. simpl. eauto.
  - (* Case "False". *) eexists. split.
    exists 0. intros. destruct n0. omega. simpl. eauto. simpl. eauto.

  - (* Case "Var". *)
    destruct (lookup_safe_ex_tnt (sanitize_env n venv0) (sanitize_env n env0) T1 x) as [v IV]. eauto. eauto.
    inversion IV as [I V].

    exists v. split. exists 0. intros. destruct n0. omega. simpl. rewrite I. eauto. eapply val_type_sanitize_tnt. eapply V.

  - (* Case "App". *)
    destruct (IHW1 venv0 WFE) as [vf [IW1 HVF]].
    destruct (IHW2 venv0 WFE) as [vx [IW2 HVX]].

    eapply invert_abs_tnt in HVF.
    destruct HVF as [venv1 [y [HF IHF]]].

    destruct (IHF vx HVX) as [vy [IW3 HVY]].

    exists vy. split. {
      (* pick large enough n. nf+nx+ny will do. *)
      destruct IW1 as [nf IWF].
      destruct IW2 as [nx IWX].
      destruct IW3 as [ny IWY].
      exists (S (nf+nx+ny)). intros. destruct n0. omega. simpl.
      rewrite IWF. subst vf. rewrite IWX. rewrite IWY. eauto.
      omega. omega. omega.
    }
    eapply HVY.

  - (* Case "Abs". *)
    eexists. split. exists 0. intros. destruct n0. omega. simpl. eauto.
    simpl. repeat split; eauto.  intros.
(*    assert (stpd2 true venv0 T1 (vx::venv0) T1). eapply stpd2_extend2. eapply stpd2_refl; eauto. eu.
    assert (stpd2 true (vx::venv0) T2 venv0 T2). eapply stpd2_extend1. eapply stpd2_refl; eauto. eu. *)

    remember (expand_env
         (expand_env (sanitize_env n venv0)
            (vrec
               (vabs (sanitize_env n venv0) m y))
            Second) vx m) as venv1.

    remember (expand_env
             (expand_env (sanitize_env n env0)
                (TRec (TFun T1 m T2)) Second) T1
             m) as tenv1.

    assert (val_type_tnt venv1 vx T1). { subst. eapply valtp_extend_tnt. eapply valtp_extend_tnt. eauto. }
    assert (wf_env_tnt venv1 tenv1). { subst. eapply wfe_tnt_env. eauto. eapply wfe_tnt_env. simpl. auto. eauto. eapply wf_idx_tnt. eapply wf_sanitize_tnt. eauto. eapply wf_idx_tnt. eapply wfe_tnt_env. simpl. auto. eauto. eapply wf_idx_tnt. eapply wf_sanitize_tnt. eauto. }
    specialize (IHW venv1 H1). destruct IHW as [v [? ?]]. exists v. split. eauto. eapply valtp_shrink_tnt. eapply valtp_shrink_tnt. subst. eauto.
  - (* Case tunrec *)
    destruct (IHW2 _ WFE) as [v [HEV HVL]].
    simpl in HVL. destruct v; inversion HVL.
Qed.


From ZornsLemma Require Import EnsemblesTactics.
Require Export TopologicalSpaces Continuity SubspaceTopology.

Section continuous_factorization.

Variable X Y:TopologicalSpace.
Variable f:point_set X -> point_set Y.
Variable S:Ensemble (point_set Y).
Hypothesis f_cont: continuous f.
Hypothesis f_img: forall x:point_set X, In S (f x).

Definition continuous_factorization :
  point_set X -> point_set (SubspaceTopology S) :=
  fun x:point_set X => exist _ (f x) (f_img x).

Lemma factorization_is_continuous:
  continuous continuous_factorization.
Proof.
red.
intros.
rewrite subspace_open_char in H.
destruct H as [V' []].
subst V.
rewrite <- inverse_image_composition.
simpl.
replace (inverse_image (fun x:point_set X => f x) V')
        with (inverse_image f V').
- now apply f_cont.
- extensionality_ensembles; now constructor.
Qed.

End continuous_factorization.

Arguments continuous_factorization {X} {Y}.

Section continuous_surj_factorization.

Variable X Y:TopologicalSpace.
Variable f:point_set X -> point_set Y.
Hypothesis f_cont: continuous f.

Definition continuous_surj_factorization :
  point_set X -> point_set (SubspaceTopology (Im Full_set f)).
apply continuous_factorization with f.
intros.
exists x; constructor.
Defined.

Lemma continuous_surj_factorization_is_surjective:
  surjective continuous_surj_factorization.
Proof.
intro.
destruct y.
destruct i.
exists x.
unfold continuous_surj_factorization, continuous_factorization.
subst.
f_equal.
f_equal.
apply proof_irrelevance.
Qed.

Lemma continuous_surj_factorization_is_continuous:
  continuous continuous_surj_factorization.
Proof.
now apply factorization_is_continuous.
Qed.

End continuous_surj_factorization.

Arguments continuous_surj_factorization {X} {Y}.


Require Import rt.util.all.
Require Import rt.model.arrival.basic.task rt.model.arrival.basic.job.
Require Import rt.model.arrival.basic.task_arrival.
Require Import rt.model.arrival.jitter.arrival_sequence.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq path.

(* In this file, we provide definitions and lemmas about task arrivals
   in jitter-aware schedules. *)
Module TaskArrivalWithJitter.

  Import ArrivalSequenceWithJitter SporadicTaskset.
  Export TaskArrival.

  (* First, we identify the arrivals of a particular task. *)
  Section NumberOfArrivals.

    Context {Task: eqType}.
    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_jitter: Job -> time.
    Variable job_task: Job -> Task.

    (* Consider any job arrival sequence ...*)
    Variable arr_seq: arrival_sequence Job.

    (* ...and recall the list of jobs with actual arrival time in a given interval. *)
    Let arrivals_between := actual_arrivals_between job_arrival job_jitter arr_seq.

    (* Next, let tsk be any task. *)
    Variable tsk: Task.

    (* By checking the jobs spawned by tsk... *)
    Definition is_job_of_tsk := is_job_of_task job_task tsk.

    (* ...we identify the jobs of tsk that arrived in any interval [t1, t2) ... *)
    Definition actual_arrivals_of_task_between (t1 t2: time) :=
      [seq j <- arrivals_between t1 t2 | is_job_of_tsk j].

    (* ...and also count the number of such job arrivals. *)
    Definition num_actual_arrivals_of_task (t1 t2: time) :=
      size (actual_arrivals_of_task_between t1 t2).

  End NumberOfArrivals.

  (* Next, we prove properties about lists of actual arrivals
     that are sorted by arrival time. *)
  Section DistanceBetweenSporadicJobs.

    Context {Task: eqType}.
    Variable task_period: Task -> time.

    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_jitter: Job -> time.
    Variable job_task: Job -> Task.

    (* Consider any arrival sequence with consistent, non-duplicate arrivals, ... *)
    Variable arr_seq: arrival_sequence Job.
    Hypothesis H_consistent_arrivals: arrival_times_are_consistent job_arrival arr_seq.
    Hypothesis H_no_duplicate_arrivals: arrival_sequence_is_a_set arr_seq.

    (* ...where jobs are sporadic. *)
    Hypothesis H_sporadic_jobs:
      sporadic_task_model task_period job_arrival job_task arr_seq.

    (* For simplicity, let's define some local names. *)
    Let actual_job_arrival := actual_arrival job_arrival job_jitter.

    (* Next, let tsk be any task to be scheduled. *)
    Variable tsk: Task.

    (* Consider any time interval [t1, t2)... *)
    Variable t1 t2: time.

    (* ...and the associated actual arrivals of task tsk. *)
    Let arriving_jobs := actual_arrivals_of_task_between job_arrival job_jitter
                                                         job_task arr_seq tsk t1 t2.
    Let num_arrivals := num_actual_arrivals_of_task job_arrival job_jitter job_task arr_seq tsk t1 t2.

    (* Then, consider the sequence of such jobs ordered by arrival times... *)
    Let by_arrival_time j j' := job_arrival j <= job_arrival j'.
    Let sorted_jobs := sort by_arrival_time arriving_jobs.

    (* ...and let (nth_job i) denote the i-th job in the sorted sequence. *)
    Variable elem: Job.
    Let nth_job := nth elem sorted_jobs.

    (* First, we recall some trivial properties about nth_job. *)
    Remark sorted_arrivals_properties_of_nth:
      forall idx,
        idx < num_arrivals ->
        t1 <= actual_job_arrival (nth_job idx) < t2 /\
        job_task (nth_job idx) = tsk /\
        arrives_in arr_seq (nth_job idx).
    Proof.
      intros idx LTidx.
      have IN: nth_job idx \in sorted_jobs by rewrite mem_nth // size_sort.
      rewrite mem_sort mem_filter in IN.
      move: IN => /andP [JOB IN]; move: (IN) => LT.
      apply in_actual_arrivals_between_implies_arrived in IN.
      eapply in_actual_arrivals_implies_arrived_between in LT.
      by repeat split; try (by done); apply/eqP.
    Qed.

    (* Next, we conclude that consecutive jobs are different. *)
    Lemma sorted_arrivals_current_differs_from_next:
      forall idx,
        idx < num_arrivals.-1 ->
        nth_job idx <> nth_job idx.+1.
    Proof.
      intros idx LT; apply/eqP.
      destruct num_arrivals eqn:EQ; first by rewrite ltn0 in LT.
      destruct n; [by rewrite ltn0 in LT | simpl in LT].
      rewrite nth_uniq ?size_sort /arriving_jobs
              -/(num_actual_arrivals_of_task _ _ _ _ _ _ _) -/num_arrivals;
        first by rewrite neq_ltn ltnSn orTb.
      - by apply leq_trans with (n := n.+1); last by rewrite EQ.
      - by rewrite EQ ltnS.
      - by rewrite sort_uniq filter_uniq //; apply actual_arrivals_uniq; eauto 1.
    Qed.

    (* Since the list is sorted, we prove that each job arrives at
       least (task_period tsk) time units after the previous job. *)
    Lemma sorted_arrivals_separated_by_period:
      forall idx,
        idx < num_arrivals.-1 ->
        job_arrival (nth_job idx.+1) >= job_arrival (nth_job idx) + task_period tsk.
    Proof.
      have NTH := sorted_arrivals_properties_of_nth.
      have NEQ := sorted_arrivals_current_differs_from_next.
      rename H_sporadic_jobs into SPO.
      intros idx LT.
      destruct num_arrivals eqn:EQ; first by rewrite ltn0 in LT.
      destruct n; [by rewrite ltn0 in LT | simpl in LT].
      exploit (NTH idx);
        [by apply leq_trans with (n := n.+1) | intro NTH1].
      exploit (NTH idx.+1); [by rewrite ltnS | intro NTH2].
      move: NTH1 NTH2 => [_ [JOB1 ARR1]] [_ [JOB2 ARR2]].
      rewrite -JOB1.
      apply SPO; try (by done); [by apply NEQ | by rewrite JOB1 JOB2 |].
      suff ORDERED: by_arrival_time (nth_job idx) (nth_job idx.+1) by done.
      apply sort_ordered;
        first by apply sort_sorted; intros x y; apply leq_total.
      rewrite size_sort.
      rewrite /arriving_jobs -/(num_actual_arrivals_of_task _ _ _ _ _ _ _) -/num_arrivals.
      by rewrite EQ.
    Qed.

    (* If the list of arrivals is not empty, we analyze the distance between
       the first and last jobs. *)
    Section FirstAndLastJobs.

      (* Suppose that there is at least one job, ... *)
      Hypothesis H_at_least_one_job:
        num_arrivals >= 1.

      (* ...in which case we identify the first and last jobs and their
         respective arrival times (note that they could be the same job). *)
      Let j_first := nth_job 0.
      Let j_last := nth_job (num_arrivals.-1).
      Let a_first := job_arrival j_first.
      Let a_last := job_arrival j_last.

      (* By induction, we prove that that each job with index 'idx' arrives at
         least idx*(task_period tsk) units after the first job. *)
      Lemma sorted_arrivals_distance_from_first_job:
        forall idx,
          idx < num_arrivals ->
          job_arrival (nth_job idx) >= a_first + idx * task_period tsk.
      Proof.
        have SEP := sorted_arrivals_separated_by_period.
        unfold sporadic_task_model in *.
        rename H_sporadic_jobs into SPO.
        induction idx; first by intros _; rewrite mul0n addn0.
        intros LT.
        have LT': idx < num_arrivals by apply leq_ltn_trans with (n := idx.+1).
        specialize (IHidx LT').
        apply leq_trans with (n := job_arrival (nth_job idx) + task_period tsk);
          first by rewrite mulSn [task_period _ + _]addnC addnA leq_add2r.
        apply SEP.
        by rewrite -(ltn_add2r 1) 2!addn1 (ltn_predK LT).
      Qed.

      (* Therefore, the first and last jobs are separated by at least
         (num_arrivals - 1) periods. *)
      Corollary sorted_arrivals_distance_between_first_and_last:
        a_last >= a_first + (num_arrivals-1) * task_period tsk.
      Proof.
        rename H_at_least_one_job into TWO.
        have DIST := sorted_arrivals_distance_from_first_job.
        rewrite subn1; apply DIST.
        by destruct num_arrivals; first by rewrite ltn0 in TWO.
      Qed.

    End FirstAndLastJobs.

  End DistanceBetweenSporadicJobs.

End TaskArrivalWithJitter.