(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

(**
* Continuity of polynomials *)

Require Export CoRN.reals.RealFuncts.

Lemma plus_op_contin : forall f g h : CSetoid_un_op IR,
 contin f -> contin g -> (forall x, f x[+]g x [=] h x) -> contin h.
Proof.
 intros f g h f_contin g_contin f_g_h.
 unfold contin in f_contin.
 unfold continAt in f_contin.
 unfold funLim in f_contin.
 unfold contin in g_contin.
 unfold continAt in g_contin.
 unfold funLim in g_contin.
 unfold contin in |- *. unfold continAt in |- *. unfold funLim in |- *.
 intros x e H.
 elim (plus_contin _ (f x) (g x) e H). intro b. intros H0 H1.
 elim H1. clear H1. intro c. intros H1 H2.
 elim (f_contin x b H0). clear f_contin. intro d'. intros H3 H4.
 elim (g_contin x c H1). clear g_contin. intro d''. intros H5 H6.
 exists (Min d' d'').
  apply less_Min; auto. intro x'. intros H10.
 astepr (f x[+]g x[-](f x'[+]g x')).
 apply H2.
  apply H4. apply AbsSmall_leEq_trans with (Min d' d''); auto. apply Min_leEq_lft.
  apply H6. apply AbsSmall_leEq_trans with (Min d' d''); auto. apply Min_leEq_rht.
Qed.

Lemma mult_op_contin : forall f g h : CSetoid_un_op IR,
 contin f -> contin g -> (forall x, f x[*]g x [=] h x) -> contin h.
Proof.
 intros f g h f_contin g_contin f_g_h.
 unfold contin in f_contin.
 unfold continAt in f_contin.
 unfold funLim in f_contin.
 unfold contin in g_contin.
 unfold continAt in g_contin.
 unfold funLim in g_contin.
 unfold contin in |- *. unfold continAt in |- *. unfold funLim in |- *.
 intros x e H.
 elim (mult_contin _ (f x) (g x) e H). intro b. intros H0 H1.
 elim H1. clear H1. intro c. intros H1 H2.
 elim (f_contin x b H0). clear f_contin. intro d'. intros H3 H4.
 elim (g_contin x c H1). clear g_contin. intro d''. intros H5 H6.
 exists (Min d' d'').
  apply less_Min; auto. intro x'. intros.
 astepr (f x[*]g x[-]f x'[*]g x').
 apply H2.
  apply H4. apply AbsSmall_leEq_trans with (Min d' d''); auto. apply Min_leEq_lft.
  apply H6. apply AbsSmall_leEq_trans with (Min d' d''); auto. apply Min_leEq_rht.
Qed.

Lemma linear_op_contin : forall (f g : CSetoid_un_op IR) a,
 contin f -> (forall x, x[*]f x[+]a [=] g x) -> contin g.
Proof.
 intros f g a f_contin f_g.
 unfold contin in f_contin.
 unfold continAt in f_contin.
 unfold funLim in f_contin.
 unfold contin in |- *. unfold continAt in |- *. unfold funLim in |- *.
 intros.
 elim (mult_contin _ x (f x) e). intro d'. intros H0 H1.
  elim H1. clear H1. intro c. intros H1 H2.
  elim (f_contin x c). clear f_contin. intro d''. intros H3 H4.
   exists (Min d' d'').
    apply less_Min; auto. intro x'. intros H8.
   astepr (x[*]f x[+]a[-](x'[*]f x'[+]a)).
   rstepr (x[*]f x[-]x'[*]f x').
   apply H2. clear H2.
    apply AbsSmall_leEq_trans with (Min d' d''); auto. apply Min_leEq_lft.
    apply H4. clear H4.
   apply AbsSmall_leEq_trans with (Min d' d''); auto. apply Min_leEq_rht.
   auto. auto.
Qed.

Lemma cpoly_op_contin : forall g : cpoly IR, contin (cpoly_csetoid_op _ g).
Proof.
 intro g.
 elim g.
  unfold contin in |- *. unfold continAt in |- *. unfold funLim in |- *.
  intros.
  exists OneR. apply pos_one.
   intros.
  simpl in |- *.
  unfold AbsSmall in |- *.
  split; apply less_leEq.
   rstepr ([--]ZeroR). apply inv_resp_less. auto.
   astepl ZeroR. auto.
  intros a f. intros.
 apply linear_op_contin with (cpoly_csetoid_op _ f) a. auto.
  intros. simpl in |- *. rational.
Qed.


Require Import Template.All.
Require Import List.
Require Import Template.Ast.
Require Import String.

Open Scope string_scope.

(* Taken from the template-coq parametricity translation *)

Definition tsl_table := list (global_reference * term).

Fixpoint lookup_tsl_table (E : tsl_table) (gr : global_reference)
  : option term :=
  match E with
  | nil => None
  | hd :: tl =>
    if gref_eq_dec gr (fst hd) then Some (snd hd)
    else lookup_tsl_table tl gr
  end.

Definition default_term := tVar "constant_not_found".

Definition lookup_default (E : tsl_table) (gr : global_reference)
  : term :=
  match (lookup_tsl_table E gr) with
  | None => match gr with
            | ConstRef n => tVar ("Not_found_" ++ n)
            | _ => default_term
            end
  | Some t => t
  end.

Import ListNotations.

(* Partly taken from Template.Typing *)
Definition it_mkLambda_or_LetIn (t : term) (l : context) :=
  List.fold_left
    (fun acc d =>
       match d.(decl_body) with
       | None => tLambda d.(decl_name) d.(decl_relevance) d.(decl_type) acc
       | Some b => tLetIn d.(decl_name) d.(decl_relevance) b d.(decl_type) acc
       end) l t.

Definition it_mkProd_or_LetIn (t : term) (l : context) :=
  List.fold_left
    (fun acc d =>
       match d.(decl_body) with
       | None => tProd d.(decl_name) d.(decl_relevance) d.(decl_type) acc
       | Some b => tLetIn d.(decl_name) d.(decl_relevance) b d.(decl_type) acc
       end) l t.

Fixpoint fold_map_internal {A B C : Type} (f : A -> B -> A * C) (a : A)
         (cs : list C) (bs : list B) : A * (list C)
  := match bs with
     | [] => (a, rev cs)
     | hd :: tl => let (a_, c_) := f a hd in fold_map_internal f a_ (c_ :: cs) tl
     end.

Definition fold_map {A B C : Type} (f : A -> B -> A * C) (a : A)
           (bs : list B) : A * (list C) := fold_map_internal f a [] bs.

Fixpoint fold_map' {A B C : Type} (f : A -> B -> A * C) (a : A)
         (bs : list B) : A * (list C)
  := match bs with
     | [] => (a, [])
     | hd :: tl => let (a_, c_) := f a hd in
                   let (a__, cs) := fold_map' f a_ tl in
                   (a__, c_ :: cs)
     end.

Example ex_fold_map : fold_map (fun x y => (x+y, y+1)) 0 [1;2;3] = (6,[2;3;4]).
reflexivity.
Qed.

Example ex_fold_map_fold_map' :
  fold_map (fun x y => (x+y, y+1)) 0 [1;2;3] = fold_map' (fun x y => (x+y, y+1)) 0 [1;2;3].
reflexivity.
Qed.

Definition sect {A B} (s : A -> B) (r : B -> A) := forall (x : A), r (s x) = x.

Definition retract {A B} (s : A -> B) (r : B -> A) := sect r s.

(* Auxiliary definitions related to equality *)
Definition transport {A : Type} {F : A -> Type} {a b : A} (p : a = b) : F a -> F b.
Proof.
  destruct p. apply id.
Defined.

(** Concatenation of paths *)
Definition path_concat {A : Type} {x y z : A} : x = y -> y = z -> x = z.
  intros p q. destruct p. apply q. Defined.

(** Lemma 2.3.9 in the HoTT book *)
Definition transp_concat {A : Type} {B : A -> Type} {x y z : A} {u : B x}
           (p : x = y) (q : y = z) :
  transport q (transport p u) = transport (path_concat p q) u.
  destruct p. reflexivity. Defined.

Definition ap {A B} (f : A -> B) {x y} : x = y -> f x = f y.
    destruct 1. reflexivity.
Defined.

(* Lemma 2.3.10 in the HoTT book *)
Definition transp_naturality {A B : Type} {C : B -> Type} {x y : A} {f : A -> B}
           {u : C (f x)} (p : x = y) :
  transport (ap f p) u =  @transport _ (fun x => C (f x)) _ _ p u.
  destruct p. reflexivity. Defined.

(* Lemma 2.3.11 in the HoTT book *)
Definition move_transport {A : Type}{F G : A -> Type}(f : forall {a : A}, F a -> G a)
           {a a' : A} (u : F a) (p : a = a') : f (transport p u) = transport p (f u).
  destruct p. reflexivity. Defined.

Definition concat_inv_r {A : Type} {x y : A} (p : x = y) :
  path_concat p (eq_sym p) = eq_refl.
  destruct p. reflexivity. Defined.

Definition concat_inv_l {A : Type} {x y : A} (p : x = y) :
  path_concat (eq_sym p) p = eq_refl.
  destruct p. reflexivity. Defined.


Require Import Metalib.Metatheory.
Require Import Metalib.LibTactics.
Require Import Coq.Program.Equality.
Require Import Coq.Program.Tactics.
Require Import Strings.String.
Require Import Lia.

Require Import Language.
Require Import Tactical.
Require Import Subtyping.Subtyping.
Require Import Subtyping.Splitable.
Require Import Appsub.

Require Import Value.
Require Import PrincipalTyping.
Require Import Typing.
Require Import Casting.
Require Import LocallyNameless.

(** * Definition *)

(** instead of using principal typing to get the type, we can define a function
    atype : vl -> arg
    atype v = Some A
    atype l = Some l
 *)

(** value and label *)

Inductive vl : Set :=
| Av : term -> vl
| Al : label -> vl.

Hint Constructors vl : core.

(** I'm confused a little bit and try to think why not let merge to be general one (work both on type and label),
    Since we can't allow label to be merged, so merge case only account for types
*)

Inductive atype : vl -> arg -> Prop :=
| At_Ann : forall e A,
    atype (Av (Ann e A)) (Avt A)
| At_Rcd : forall e l A,
    atype (Av e) (Avt A) ->
    atype (Av (Fld l e)) (Avt (Rcd l A))
| At_Mrg : forall e1 e2 A1 A2,
    atype (Av e1) (Avt A1) ->
    atype (Av e2) (Avt A2) ->
    atype (Av (Mrg e1 e2)) (Avt (And A1 A2))
| At_Lbl : forall l,
    atype (Al l) (Alt l).

Hint Constructors atype : core.

Inductive papp : term -> vl -> term -> Prop :=
| Pa_Lam : forall A B C D v v' e,
    lc (Lam A e B) ->
    casting v A v' ->
    papp (Ann (Lam A e B) (Arr C D)) (Av v)
         (Ann (open e v') D)
| Pa_Rcd : forall v l,
    papp (Fld l v) (Al l) v
| Pa_Mrg_L : forall v1 v2 A B vl TA e,
    ptype v1 A -> ptype v2 B ->
    atype vl TA ->
    not (uunisub B (uV TA) None) ->
    papp v1 vl e ->
    papp (Mrg v1 v2) vl e
| Pa_Mrg_R : forall v1 v2 A B vl TA e,
    ptype v1 A -> ptype v2 B ->
    atype vl TA ->
    not (uunisub A (uV TA) None) ->
    papp v2 vl e ->
    papp (Mrg v1 v2) vl e
| Pa_Mrg_P : forall v1 v2 A B vl TA e1 e2,
    ptype v1 A -> ptype v2 B ->
    atype vl TA ->
    uunisub A (uV TA) None ->
    uunisub B (uV TA) None ->
    papp v1 vl e1 ->
    papp v2 vl e2 ->
    papp (Mrg v1 v2) vl (Mrg e1 e2).

Hint Constructors papp : core.

Notation "v · vl ⟹ e" := (papp v vl e) (at level 69).

(** * Determinism *)

Lemma atype_determinism :
  forall vl TA1 TA2,
    atype vl TA1 ->
    atype vl TA2 ->
    TA1 = TA2.
Proof.
  introv At1 At2. gen TA2.
  dependent induction At1; intros.
  - dependent destruction At2; eauto.
  - dependent destruction At2; eauto.
    pose proof (IHAt1 _ At2) as IH.
    dependent destruction IH; eauto.
  - dependent destruction At2.
    pose proof (IHAt1_1 _ At2_1) as IH1.
    pose proof (IHAt1_2 _ At2_2) as IH2.
    dependent destruction IH1. dependent induction IH2.
    auto.
  - dependent destruction At2; eauto.
Qed.

Ltac subst_atype :=
  match goal with
  | [H1: atype ?vl ?TA1, H2: atype ?vl ?TA2 |- _] =>
      (pose proof (atype_determinism _ _ _ H1 H2) as Eqs; subst; clear H2)
  end.

Lemma typing_to_atype :
  forall v A,
    value v ->
    typing nil v Inf A ->
    atype (Av v) (Avt A).
Proof.
  introv Val Typ. gen A.
  induction Val; intros.
  - dependent destruction Typ; eauto.
  - dependent destruction Typ; eauto.
  - dependent destruction Typ; eauto.
Qed.

Hint Resolve typing_to_atype : core.

(** * App & Value *)

Lemma papp_lc_v :
  forall v vl e,
    lc v -> lc vl ->
    papp v (Av vl) e ->
    lc e.
Proof.
  introv Lc Lcl Pa.
  dependent induction Pa; try solve [econstructor; eauto 3].
  - econstructor. eapply open_abs; eauto 3.
    eapply casting_lc; eauto.
  - dependent destruction Lc; eauto 3.
  - dependent destruction Lc; eauto 3.
Qed.

Lemma papp_lc_l :
  forall v vl e,
    lc v ->
    papp v (Al vl) e ->
    lc e.
Proof.
  introv Lc Pa.
  dependent induction Pa; try solve [econstructor; eauto 3].
  - dependent destruction Lc. assumption.
  - dependent destruction Lc; eauto 3.
  - dependent destruction Lc; eauto 3.
Qed.

(** * Weakening Lemma *)

Lemma typing_weakening_gen :
  forall G E F e A dir,
    typing (E ++ G) e dir A ->
    uniq (E ++ F ++ G) ->
    typing (E ++ F ++ G) e dir A.
Proof.
  introv Typ. gen F.
  dependent induction Typ; introv Env; eauto.
  pick fresh x and apply Ty_Lam.
  rewrite_env (([(x,A)] ++ E) ++ F ++ G).
  apply H0; eauto.
  solve_uniq.
Qed.

Lemma typing_weakening :
  forall E F e A dir,
    typing E e dir A ->
    uniq (F ++ E) ->
    typing (F ++ E) e dir A.
Proof.
  intros.
  rewrite_env (nil ++ F ++ E).
  eapply typing_weakening_gen; eauto.
Qed.

(** * Subsitution Lemma *)

Lemma typing_uniq :
  forall E e T,
    typing E e Inf T -> uniq E.
Proof.
  introv Typ.
  induction Typ; eauto.
  - pick fresh x.
    assert (J: uniq ((one (x,A)) ++ T)); eauto.
    dependent destruction J; eauto.
Qed.

Lemma fv_open_lower :
  forall e1 e2 k,
    fv e1 [<=] fv (open_rec k e2 e1).
Proof with auto.
  intros.
  generalize dependent k.
  induction e1; intros; simpl; try fsetdec...
  - specialize (IHe1_1 k).
    specialize (IHe1_2 k).
    fsetdec...
  - specialize (IHe1_1 k).
    specialize (IHe1_2 k).
    fsetdec...
Qed.

Lemma fv_in_dom :
  forall T e A dir,
    typing T e dir A -> fv e [<=] dom T.
Proof.
  introv Typ.
  dependent induction Typ; simpl; try fsetdec; eauto.
  - apply binds_In in H0.
    fsetdec.
  - pick fresh x.
    assert ((fv (open e x)) [<=] (dom ((one (x, A)) ++ T))) by eauto.
    simpl in *.
    assert (fv e [<=] fv (open e x)).
    eapply fv_open_lower.
    assert (fv e [<=] add x (dom T)).
    fsetdec.
    eapply add_notin_context; eauto.
Qed.

Lemma subst_value :
  forall e z u A ,
    typing nil e Inf A -> substitution z u e = e.
Proof with auto.
  intros.
  apply fv_in_dom in H...
  simpl in H...
  eapply subst_fresh; eauto.
  fsetdec.
Qed.

(** substitution lemma,
stating that substituting a (closed, well-typed) term s for a variable x in a term t preserves the type of t *)

Lemma substitution_lemma :
   forall F E x v e A B C dir,
    typing (F ++ [(x, A)] ++ E) e dir B ->
    typing nil v Inf C ->
    isosub C A ->
    (exists D, typing (F ++ E) (substitution x v e) dir D /\ isosub D B).
Proof.
  introv Typ Typv Isub. remember (F ++ [(x, A)] ++ E) as E'. gen F.
  induction Typ; intros; simpl; subst; eauto.
  - Case "Var".
    destruct (x0 == x); eauto. subst.
    eapply binds_mid_eq in H0; eauto. subst.
    exists C. split; eauto.
    eapply typing_weakening; eauto.
    rewrite_env (E ++ nil).
    eapply typing_weakening; eauto.
    solve_uniq.
  - Case "Lam".
    exists (Arr A0 B). split; eauto.
    eapply (Ty_Lam (union L (singleton x))); eauto. intros.
    pose proof (H0 x0) as IH.
    exploit IH; eauto. intros IH'. destruct_conjs.
    rewrite_env (([(x0, A0)] ++ F) ++ E).
    rewrite subst_open_var; eauto 3.
    eapply isosub_to_sub1 in H3.
    eapply typing_chk_sub; eauto.
  - Case "Rcd".
    pose proof (IHTyp F) as IH. exploit IH; eauto. intros IH'.
    destruct IH'. destruct H. exists (Rcd l x0). split; eauto.
  - Case "Ann".
    exists A0. split; eauto.
    pose proof (IHTyp F) as IH. destruct IH; eauto. destruct_conjs.
    eapply Ty_Ann; eauto. eapply isosub_to_sub1 in H0.
    eapply typing_chk_sub; eauto.
  - Case "App".
    pose proof (IHTyp1 F) as IH1. pose proof (IHTyp2 F) as IH2.
    destruct IH1; destruct IH2; eauto. destruct_conjs.
    eapply uunisub_sound_appsub in H.
    eapply appsub_iso_v in H; eauto. destruct H. destruct H.
    exists x2. split; eauto. eapply Ty_App; eauto.
    eapply uunisub_complete_appsub; eauto.
  - Case "Prj".
    pose proof (IHTyp F) as IH. exploit IH; eauto. intros IH'.
    destruct IH'. destruct H0.
    eapply uunisub_sound_appsub in H.
    eapply appsub_iso_l in H; eauto. destruct H. destruct H.
    exists x1. split; eauto. eapply Ty_Prj; eauto.
    eapply uunisub_complete_appsub; eauto.
  - Case "Merge".
    pose proof (IHTyp1 F) as IH1. pose proof (IHTyp2 F) as IH2.
    destruct IH1; destruct IH2; eauto. destruct_conjs. eauto.
  - Case "Sub".
    pose proof (IHTyp F). destruct H0; eauto. destruct H0.
    exists B. split; eauto. eapply isosub_to_sub1 in H1.
    eapply Ty_Sub; eauto. eapply sub_transitivity; eauto.
Qed.

(** * Preservation *)
Section papp_preservation.

Lemma papp_uvalue_v :
  forall v vl e A B,
    value v -> value vl ->
    typing nil v Inf A -> typing nil vl Inf B ->
    papp v (Av vl) e ->
    uvalue e.
Proof.
  introv Val Vall Typ Typl Pa. gen A B.
  dependent induction Pa; intros; eauto 3.
  - dependent destruction Val. dependent destruction Typ; eauto.
  - dependent destruction Val. dependent destruction Typ; eauto 3.
  - dependent destruction Val. dependent destruction Typ; eauto 3.
  - eapply Uv_Mrg;
    dependent destruction Val; dependent destruction Typ; eauto 3.
Qed.

Lemma papp_uvalue_l :
  forall v l e A,
    value v ->
    typing nil v Inf A ->
    papp v (Al l) e ->
    uvalue e.
Proof.
  introv Val Typ Pa. gen A.
  dependent induction Pa; intros; eauto 3.
  - dependent destruction Val. dependent destruction Typ; eauto.
  - dependent destruction Val. dependent destruction Typ; eauto 3.
  - dependent destruction Val. dependent destruction Typ; eauto 3.
  - eapply Uv_Mrg;
    dependent destruction Val; dependent destruction Typ; eauto 3.
Qed.

Ltac solver1 := repeat match goal with
                       | [Typ: typing nil ?v Inf ?A, Val: value ?v, Pt: ptype ?v _ |- _] =>
                           (pose proof (typing_to_ptype _ _ (value_is_uvalue _ Val) Typ); subst_ptype; clear Pt)
                       | Typ: typing nil ?v Inf ?A, Val: value ?v, At: atype (Av ?v) _ |- _ =>
                           pose proof (typing_to_atype _ _ Val Typ);
                           subst_atype; clear At
                       end.

Lemma papp_preservation_v :
  forall v vl e A B C,
    value v -> value vl ->
    typing nil v Inf A ->
    typing nil vl Inf B ->
    appsub (Some (Avt B)) A C ->
    papp v (Av vl) e ->
    (exists D, typing nil e Inf D /\ isosub D C).
Proof.
  introv Val Vall Typ Typl As Pa. gen A B C.
  dependent induction Pa; intros.
  - Case "Lam".
    repeat dependent destruction Typ. dependent destruction As.
    dependent destruction Val.
    match goal with
    | [H: sub (Arr _ _) (Arr _ _) |- _] => (dependent destruction H; eauto)
    end.
    exists D. split; eauto.
    match goal with
    | [H: casting _ _ _ |- _] => (eapply casting_preservation in H; eauto; destruct H; destruct H)
    end.
    pick fresh y. rewrite (subst_intro y); eauto.
    assert (Fr': y `notin` L) by eauto.
    pose proof (H3 y Fr').
    rewrite_env (nil ++ [(y, A)] ++ nil) in H7.
    pose proof (substitution_lemma nil nil y v' (open e y) A B x Chk) as Sl.
    destruct Sl as [x' Sl']; eauto. destruct Sl'.
    eapply Ty_Ann; eauto.
    eapply isosub_to_sub1 in H9; eauto.
    eapply typing_chk_sub; eauto.
    eapply sub_transitivity; eauto 3.
  - Case "Merge L".
    dependent destruction Val. dependent destruction Typ;
      dependent destruction As; eauto 3; solver1; eauto.
  - Case "Merge R".
    dependent destruction Val. dependent destruction Typ;
      dependent destruction As; eauto 3; solver1; eauto.
  - Case "Merge P".
    dependent destruction Val. dependent destruction Typ.
    solver1.
    dependent destruction As; eauto.
    exploit (IHPa1 Val1 _ Vall); eauto.
    exploit (IHPa2 Val2 _ Vall); eauto.
    intros IH2 IH1.
    destruct_conjs. exists (And IH1 IH2). split; eauto.
Qed.

Ltac solver2 := repeat match goal with
                       | [Typ: typing nil ?v Inf ?A, Val: value ?v, Pt: ptype ?v _ |- _] =>
                           (pose proof (typing_to_ptype _ _ (value_is_uvalue _ Val) Typ); subst_ptype; clear Pt)
                       | At: atype (Al _) _ |- _ =>
                           dependent destruction At
                  end.

Lemma papp_preservation_l :
  forall v l e A B,
    value v ->
    typing nil v Inf A ->
    appsub (Some (Alt l)) A B ->
    papp v (Al l) e ->
    (exists C, typing nil e Inf C /\ isosub C B).
Proof.
  introv Val Typ As Pa. gen A B.
  dependent induction Pa; intros.
  - Case "Prj".
    dependent destruction Typ. dependent destruction As.
    exists A. split; eauto.
  - Case "Merge L".
    dependent destruction Val. dependent destruction Typ;
      dependent destruction As; eauto 3; solver2; eauto.
  - Case "Merge R".
    dependent destruction Val. dependent destruction Typ;
      dependent destruction As; eauto 3; solver2; eauto.
  - Case "Merge P".
    dependent destruction Val. dependent destruction Typ.
    solver2.
    dependent destruction As; eauto.
    exploit (IHPa1 l Val1); eauto.
    exploit (IHPa2 l Val2); eauto.
    intros IH2 IH1.
    destruct_conjs. exists (And IH1 IH2). split; eauto.
Qed.

End papp_preservation.

(** * Progress *)

Lemma papp_progress_v :
  forall f v A B C,
    value f -> value v ->
    typing nil f Inf A -> typing nil v Inf B ->
    appsub (Some (Avt B)) A C ->
    exists e, papp f (Av v) e.
Proof.
  introv Vf Vv Tf Tv As. gen A B C v.
  induction Vf; intros.
  - Case "Anno".
    destruct H.
    + SCase "Lit".
      repeat dependent destruction Tf.
      dependent destruction H1; eauto.
    + SCase "Lam".
      repeat dependent destruction Tf.
      dependent destruction H2; eauto.
      dependent destruction As; eauto.
      assert (Sub: sub B1 A1) by (eapply sub_transitivity; eauto).
      pose proof (casting_progress' _ _ _ Vv Tv Sub) as Ct. destruct Ct.
      eexists. eapply Pa_Lam; eauto.
  - Case "Rcd".
    dependent destruction Tf; eauto.
  - Case "Merge".
    dependent destruction As.
    + inversion Tf.
    + dependent destruction Tf.
      pose proof (IHVf1 _ Tf1 _ _ As _ Vv Tv) as IH. destruct IH.
      eexists. eapply Pa_Mrg_L; eauto.
    + dependent destruction Tf.
      pose proof (IHVf2 _ Tf2 _ _ As _ Vv Tv) as IH. destruct IH.
      eexists. eapply Pa_Mrg_R; eauto.
    + dependent destruction Tf.
      pose proof (IHVf1 _ Tf1 _ _ As1 _ Vv Tv) as IH1. destruct IH1.
      pose proof (IHVf2 _ Tf2 _ _ As2 _ Vv Tv) as IH2. destruct IH2.
      eexists. eapply Pa_Mrg_P; eauto.
Qed.

Lemma papp_progress_l :
  forall v A B l,
    value v ->
    typing nil v Inf A ->
    appsub (Some (Alt l)) A B ->
    exists e, papp v (Al l) e.
Proof.
  introv Val Typ As. gen A B l.
  induction Val; intros.
  - Case "Ann". destruct H.
    + SCase "Lit".
      repeat dependent destruction Typ.
      dependent destruction H1; eauto.
    + SCase "Lam".
      repeat dependent destruction Typ.
      dependent destruction H2; eauto.
  - Case "Rcd".
    dependent destruction Typ; eauto.
    dependent destruction As. eauto.
  - Case "Merge".
    dependent destruction As.
    + inversion Typ.
    + dependent destruction Typ.
      pose proof (IHVal1 _ Typ1 _ _ As) as IH. destruct IH.
      eexists. eapply Pa_Mrg_L; eauto.
    + dependent destruction Typ.
      pose proof (IHVal2 _ Typ2 _ _ As) as IH. destruct IH.
      eexists. eapply Pa_Mrg_R; eauto.
    + dependent destruction Typ.
      pose proof (IHVal1 _ Typ1 _ _ As1) as IH1. destruct IH1.
      pose proof (IHVal2 _ Typ2 _ _ As2) as IH2. destruct IH2.
      eexists. eapply Pa_Mrg_P; eauto.
Qed.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

 This tests the static semantics of statements and expressions, pg. 63.

*)
Set Implicit Arguments.
Require Import Cyclone_Static_Semantics.
Require Import Cyclone_Test_Utilities.
Require Import Cyclone_LN_Tactics.
Close Scope list_scope.
Import LibEnvNotations.
Import LVPE.LibVarPathEnvNotations.

(* Automating these rules is still a bit of a mystery.
These three are L and a Tau and are the hardest.
styp_let_3_6
styp_open_3_7
styp_openstar_3_8

 These three are L but no Tau.
SR_3_13
SR_3_12
K_etype

 The cases I have here may or may not be needed in the proofs,
so I may wait until a proof case comes up then automate.

 I can automate simpl_K being called and I can automate and
rename apply_fresh_fresh with a simpl_env to make this a
bit easier.
*)

Example p63_1:
  styp empty LVPE.V.empty empty
       (letx (i_e (i_i 0)) (e_s (p_e (bevar 0) nil)))
       cint.
Proof.
  apply_fresh styp_let_3_6; auto.
  (* But I'm not really solving the undirected type issues. *)
Qed.

Ltac fv_of_static_goal ::=
  idtac "fv_of_static_goal";
  trace_goal;
  match goal with
    | |- styp ?d ?u ?g ?s ?t =>
      constr:(\{})
(*
      constr:((fv_delta d) \u (fv_upsilon u) \u (fv_gamma g) \u (TTM.fv_st s)
                           \u (TM.fv_st s) \u (T.fv t))
*)
(*
    | |- ltyp ?d ?u ?g ?e ?t =>
      constr:((fv_delta d) \u (fv_upsilon u) \u (fv_gamma g) \u (TTM.fv_e e)
                           \u (TM.fv_e e) \u (T.fv t))
    | |- rtyp ?d ?u ?g ?e ?t =>
      constr:((fv_delta d) \u (fv_upsilon u) \u (fv_gamma g) \u (TTM.fv_e e)
                           \u (TM.fv_e e) \u (T.fv t))
*)
  end.

Example fvar_in_goal:
  forall x d u g,
    styp d u g
         (letx (v_e (fevar x))
               (letx (amp (p_e (bevar 1) nil)) (e_s (p_e (bevar 0) nil))))
         (ptype cint).
Proof.
  intros.
  apply_fresh styp_let_3_6 with type cint.
Admitted.

Example p63_2:
    styp empty LVPE.V.empty empty
         (letx (i_e (i_i 0))
               (letx (amp (p_e (bevar 1) nil)) (e_s (p_e (bevar 0) nil))))
         (ptype cint).
Proof.
  apply_fresh styp_let_3_6 with type cint.
  admit.
  auto.
  auto.
(*
    [simpl; case_nat; case_nat| auto | auto].
  apply_fresh_from' styp_let_3_6 with (fv_of_static_goal) also (ptype cint);
    [simpl; case_nat | auto | auto].
  auto.
*)
Qed.

Example p62_3:
    styp empty LVPE.V.empty empty
         (letx (i_e (i_i 0))
               (letx (amp (p_e (bevar 1) nil))
                     (letx (pack cint
                                 (cpair (amp (p_e (bevar 2) nil)) (p_e (bevar 2) nil))
                                 (etype aliases B (cross (ptype (btvar 0)) (btvar 0))))
                        (e_s (p_e (bevar 0) nil)))))
         (etype aliases B (cross (ptype (btvar 0)) (btvar 0))).
Proof.
  apply_fresh_from' styp_let_3_6 with (fv_of_static_goal) also cint;
  [simpl_env; try simpl_K | auto | auto].
  apply_fresh_from' styp_let_3_6 with (fv_of_static_goal) also (ptype cint);
    [ simpl_env; try simpl_K| auto | auto].
  foo.
  auto.
(* Once there are no existential variables, it solves these. *)
(*  apply_fresh_from' styp_let_3_6 with (fv_of_static_goal) also (ptype cint);
    try simpl_env; auto. *)
Qed.

Example p63_4:
    styp empty LVPE.V.empty empty
         (letx (i_e (i_i 0))
               (letx (amp (p_e (bevar 1) nil))
                     (letx (pack cint
                                 (cpair (amp (p_e (bevar 2) nil)) (p_e (bevar 2) nil))
                                 (etype aliases B (cross (ptype (btvar 0)) (btvar 0))))
                           (openstar (p_e (bevar 1) nil)
                                     (e_s (p_e (bevar 0) nil))))))
         (ptype (etype aliases B (cross (ptype (btvar 0)) (btvar 0)))).
Proof.
  apply_fresh_from' styp_let_3_6 with (fv_of_static_goal) also cint;
    try simpl_env; try simpl_K;
   [ idtac | auto].
  apply_fresh_from' styp_let_3_6 with (fv_of_static_goal)
    also (ptype cint);
    try simpl_env; try simpl_K;
    [idtac | auto].
  apply_fresh_from' styp_let_3_6 with (fv_of_static_goal)
  also (etype aliases B (cross (ptype (btvar 0)) (btvar 0)));
    try simpl_env; try simpl_K;
    [idtac | auto].
  apply styp_openstar_3_8 with
  (L:= (\{ y} \u \{ y0}) \u \{ y1})
    (tau':= (etype aliases B (cross (ptype (btvar 0)) (btvar 0))))
    (k:= B);
    try simpl_env; try simpl_K;
      [idtac | auto].
  intros.
  constructor.
  apply SR_3_1 with (tau':= (ptype (etype aliases B (cross (ptype (btvar 0)) (btvar 0)))));
    auto.
Qed.

Example p63_4_open:
    styp empty LVPE.V.empty empty
         (letx (i_e (i_i 0))
               (letx (amp (p_e (bevar 1) nil))
                     (letx (pack cint
                                 (cpair (amp (p_e (bevar 2) nil)) (p_e (bevar 2) nil))
                                 (etype aliases B (cross (ptype (btvar 0)) (btvar 0))))
                           (openx (p_e (bevar 1) nil)
                                     (e_s (p_e (bevar 0) nil))))))
         (etype aliases B (cross (ptype (btvar 0)) (btvar 0))).
Proof.
  apply_fresh_from' styp_let_3_6 with (fv_of_static_goal) also cint;
    try simpl_env; try simpl_K;
   [ idtac | auto].
  apply_fresh_from' styp_let_3_6 with (fv_of_static_goal)
    also (ptype cint);
    try simpl_env; try simpl_K;
    [idtac | auto].
  apply_fresh_from' styp_let_3_6 with (fv_of_static_goal)
  also (etype aliases B (cross (ptype (btvar 0)) (btvar 0)));
    try simpl_env; try simpl_K;
    [idtac | auto].
(*
  apply styp_openstar_3_8 with
  (L:= (\{ y} \u \{ y0}) \u \{ y1})
    (tau':= (etype aliases B (cross (ptype (btvar 0)) (btvar 0))))
    (k:= B);
    try simpl_env; try simpl_K;
      [idtac | auto].
  intros.
  constructor.
  apply SR_3_1 with (tau':= (ptype (etype aliases B (cross (ptype (btvar 0)) (btvar 0)))));
    auto.
Qed.
 *)
Admitted.

(* Test ret, the return checker. *)

Example ret_ret_test:
  ret (retn e).
Proof.
  auto. (* apply ret_ret.*)
Qed.

Example ret_if_test_not:
  ~ret (if_s e (e_s (i_e (i_i 0))) (e_s (i_e (i_i 0)))).
Proof.
  intros H.
  inversion H.
  inversion H2.
Qed.

Example ret_if_test:
  ret (if_s e (retn (i_e (i_i 0))) (retn (i_e (i_i 0)))).
Proof.
  auto. (* apply ret_if;*)
Qed.

Example ret_seq_1_test:
 ret (seqx (retn (i_e (i_i 0))) (e_s (i_e (i_i 0)))).
Proof.
  auto. (* apply ret_seq_1;*)
Qed.

Example ret_seq_2_test:
  ret (seqx (e_s (i_e (i_i 0))) (retn (i_e (i_i 0)))).
Proof.
  auto.
  (* apply ret_seq_2;*)
Qed.

Example ret_let_test:
  ret (letx e (retn (i_e (i_i 0)))).
Proof.
  auto. (* apply ret_let.*)
Qed.

Example ret_open_test:
  ret (openx e (retn (i_e (i_i 0)))).
Proof.
  auto. (* apply ret_open.*)
Qed.

Example ret_openstar_test:
  ret (openstar e (retn (i_e (i_i 0)))).
Proof.
  auto. (* apply ret_openstar.*)
Qed.

(* Test ltyp. *)

Example SL_3_1_test:
  ltyp empty LVPE.V.empty (empty & (varx ~ cint))  (p_e (fevar varx) nil) cint.
Proof.
  auto.
Qed.

Example SL_3_2_test:
  ltyp empty LVPE.V.empty (empty & (varx ~ (ptype cint))) (star (p_e (fevar varx) nil)) cint.
Proof.
  auto.
  (* apply SL_3_2. *)
Qed.

Example SL_3_3_test:
  ltyp empty LVPE.V.empty (empty & (varx ~ (cross cint cint)))
       (dot (p_e (fevar varx) nil) zero_pe) cint.
Proof.
  auto.
(*
  apply SL_3_3 with (t1:=cint).
  apply SL_3_1 with (tau':= (cross cint cint));
  auto.
*)
Qed.

Example SL_3_4_test:
  ltyp empty LVPE.V.empty (empty & (varx ~ (cross cint cint))) (dot (p_e (fevar varx) nil) one_pe) cint.
Proof.
  auto. (* apply SL_3_4 with (t0:=cint);   auto.*)
Qed.

(* Test styp *)
(* Return at the end of a program, any old type will do. *)
Example styp_e_test:
  styp empty LVPE.V.empty empty (e_s e) tau.
Proof.
  unfold_test_utilities.
  auto.
(*
  applys~ styp_e_3_1.
  auto.
  apply styp_e_3_1 with (tau':= cint);
  auto.
*)
Qed.

Example styp_return_test:
  styp empty LVPE.V.empty empty (retn e) tau.
Proof.
  unfold_test_utilities.
  auto.
(*  apply styp_return_3_2; *)
Qed.

Example styp_seq_test:
  styp empty LVPE.V.empty empty (seqx s1 s2) tau.
Proof.
  unfold_test_utilities.
  auto.
  (* apply styp_seq_3_3; *)
Qed.

Example styp_while_test:
  styp empty LVPE.V.empty empty (while e s) tau.
Proof.
  unfold_test_utilities.
  auto.
  (* apply styp_while_3_4; *)
Qed.

Example styp_if_test:
  styp empty LVPE.V.empty empty (if_s e s1 s2) tau.
Proof.
  unfold_test_utilities.
  auto.
  (* apply styp_if_3_5; *)
Qed.

Example styp_let_test:
  styp empty LVPE.V.empty empty (letx e s) tau.
Proof.
  unfold_test_utilities.
  auto.
  (* apply_fresh_from* styp_let_3_6 with fv_of_static_goal. *)
  (* apply styp_let_3_6 with (L:= ltac(fv_of_static_goal)) (tau':= cint); auto. *)
Qed.

Example K_B_test:
  K ((alpha_ ~ B) & empty) (ftvar alpha_) B.
Proof.
  auto.
  (* apply K_B; auto *)
Qed.

(* Let's make some polymorphic pairs. *)
Definition axaa  := etype aliases A (cross (btvar 0) (btvar 0)).
Definition paxaa := pack cint (cpair (i_e (i_i 0)) (i_e (i_i 1))) axaa.
(* alpha is bound here to the witness type so we can pass it on inside. *)
Definition oaxaa := openx paxaa (e_s (p_e (bevar 0) (cons (i_pe zero_pe) nil))).
(*
Example styp_open_test:
  styp empty LVPE.V.empty empty
       cint
       oaxaa.
Proof.
  unfold_test_utilities.
  unfold oaxaa, paxaa, axaa.
  apply styp_open_3_7
        with (L := \{})
             (p    := aliases)
             (k    := B)
             (tau  := cint)
             (tau' := (cross (btvar 0) (btvar 0))).
  simpl.
  case_nat.
  intros.
  apply styp_e_3_1 with (tau':= cint).
  admit.

  apply_fresh_from styp_open_3_7 with fv_of_static_goal.
  simpl.
  intros.
  case_nat~.

  admit.
  auto.

   auto.
Qed.

Example styp_openstar_test:
  styp empty LVPE.V.empty empty
       cint
       (openstar (pack cint
                   (cpair (i_e (i_i 0)) (i_e (i_i 1)))
                   (etype aliases alpha B
                          (cross (tv_t alpha) (tv_t alpha))))
             alpha x (e_s (p_e x [i_pe zero_pe]))).
Proof.
  apply styp_openstar_3_8
        with (k    := B)
             (tau  := cint)
             (tau' := (cross (tv_t alpha) (tv_t alpha)));
  auto.
Qed.

*)

(* Test rtyp. *)

(* Bug 26, bad contexting in SR_3_2. *)
Example SR_3_1_test:
  rtyp empty LVPE.V.empty (empty & (varx ~ tau)) (p_e x nil) tau.
Proof.
  unfold tau.
  auto.
  (* apply SR_3_1 with (tau':= tau);
  auto. *)
Qed.

Example SR_3_2_test:
  rtyp empty LVPE.V.empty (empty & (varx ~ (ptype cint))) (star (p_e x nil)) cint.
Proof.
  auto.
  (* apply SR_3_2;
  auto. *)
Qed.

Example SR_3_3_test:
  rtyp empty LVPE.V.empty empty (dot (cpair (i_e (i_i 0)) (i_e (i_i 1))) zero_pe) cint.
Proof.
  auto.
  (* apply SR_3_3 with (t1:=cint); *)
Qed.

Example SR_3_4_test:
  rtyp empty LVPE.V.empty (empty & (varx ~ (cross cint cint)))
       (dot (p_e x nil) one_pe) cint.
Proof.
  auto.
  (* apply SR_3_4 with (t0:= cint). *)
Qed.

Example SR_3_5_test:
  rtyp empty LVPE.V.empty empty (i_e (i_i 0)) cint.
Proof.
  auto.
  (* apply SR_3_5. *)
Qed.

(* Bug 27, star instead of amp. *)
Example SR_3_6_test:
  rtyp empty LVPE.V.empty (empty & (varx ~ (cross cint cint)))
       (amp (p_e x nil)) (ptype (cross cint cint)).
Proof.
  auto.
  (* apply SR_3_6. *)
Qed.

Example SR_3_7_test:
  rtyp empty LVPE.V.empty empty (cpair (i_e (i_i 0)) (i_e (i_i 1))) (cross cint cint).
Proof.
  auto.
  (* apply SR_3_7;*)
Qed.

Example SR_3_8_test:
  rtyp empty LVPE.V.empty (empty & (varx ~ cint))
       (assign (p_e x nil) (i_e (i_i 0))) cint.
Proof.
  auto.
  (* apply SR_3_8. *)
Qed.

Example SR_3_9_test:
  rtyp empty LVPE.V.empty empty
       (appl (f_e (dfun cint cint (retn (p_e (bevar 0) nil))))
             (i_e (i_i 0)))
       cint.
Proof.
  (* apply SR_3_9 with (tau':= cint);   auto. *)
  auto.
(*
  applys~ SR_3_9.
  apply_fresh_from* SR_3_13 with fv_of_static_goal.
  simpls~.
  case_nat~.
  destruct (classicT (0 = 0)).
  auto.
  tryfalse.
*)
Qed.

Example SR_3_10_test:
  rtyp empty LVPE.V.empty empty
       (call (retn (i_e (i_i 0))))
       cint.
Proof.
  auto.
  (* apply SR_3_10;
  auto.*)
Qed.

(* Bogus: can't instantiate anything but a universal type.
Example SR_3_11_test_simpl:
  rtyp
    empty LVPE.V.empty ((varx ~ cint) & empty)
    (inst (p_e (fevar varx) nil)
          cint)
    cint.
Proof.
  apply SR_3_11 with (k:= B) (tau':= cint); auto. (* 20 runs way too many times. *)
  apply SR_3_1 with (tau':= cint).
  auto.
  admit.
  auto.
  auto.
Qed.
*)

Example SR_3_11_test:
  rtyp
    empty LVPE.V.empty empty
    (inst (f_e (ufun B (dfun (btvar 0) (btvar 0) (retn (p_e (bevar 0) nil)))))
          cint)
    (arrow cint cint).
Proof.
  apply SR_3_11 with
          (k := B)
            (tau':= (arrow (btvar 0) (btvar 0)));
    try solve[auto]; try solve[simpl; case_nat~].
Qed.

Example simplest_pack:
  rtyp empty LVPE.V.empty (empty & (varx ~ cint))
        (pack cint (p_e (fevar varx) nil)
              (etype aliases B (btvar 0)))
        (etype aliases B (btvar 0)).
Proof.
  auto.
Qed.

Example pack_int:
  rtyp empty LVPE.V.empty ( empty & (varx ~ cint))
        (pack cint (p_e (fevar varx) nil)
              (etype aliases B (btvar 0)))
        (etype aliases B (btvar 0)).
Proof.
 apply_fresh_from* SR_3_12 with fv_of_static_goal.
Qed.

Example pack_int_star:
  rtyp empty LVPE.V.empty (empty & (varx ~ cint))
        (pack cint (amp (p_e (fevar varx) nil))
              (etype aliases B (ptype (btvar 0))))
        (etype aliases B (ptype (btvar 0))).
Proof.
 apply_fresh_from SR_3_12 with fv_of_static_goal; auto.
Qed.

(*
Example pack_int_open:
  varx <> vary ->
  styp empty LVPE.V.empty (empty & (varx ~ cint) & (vary ~ cint))
        cint
        (openx (pack cint (p_e (fevar varx) nil) (etype aliases B (btvar 0)))
               (e_s (p_e (fevar vary) nil))).
Proof.
  intros.
  apply styp_open_3_7
  with (L:=\{varx})
       (k:=B)
       (tau':= (etype aliases B cint)); try simpl_env; auto.
  intros.
  constructor.
  applys~ SR_3_1; try simpl_env. (* BUG simp_env breaking *)
  (* WFC deficiency *)
  admit.
  apply_fresh_from' SR_3_12 with (fv_of_static_goal) also (etype aliases B cint).

try simpl_env; auto.

  auto.
Qed.

Example let_pack_openstar:
  styp empty LVPE.V.empty ((varx ~ cint) & empty)
       cint
  (letx (pack cint (p_e (fevar varx) nil) (etype aliases B (btvar 0)))
        (openstar (p_e (bevar 0) nil)
                  (e_s (assign (star (p_e (bevar 0) nil)) (i_e (i_i 7)))))).
Proof.
  apply styp_let_3_6 with
  (L:= (fv_delta empty \u fv_upsilon LVPE.V.empty) \u fv_gamma (varx ~ cint & empty))
  (tau':= (etype aliases B (btvar 0))).
  (* apply_fresh_from styp_let_3_6 with fv_of_static_goal.*)
  intros.
  simpl.
  case_nat.
  case_nat.
  apply styp_openstar_3_8
  with (L:= \{varx} \u (fv_delta empty \u fv_upsilon LVPE.V.empty) \u fv_gamma (varx ~ cint & empty))
         (k:= B)
         (tau':= cint).
  simpl.
  intros.
  case_nat.
  constructor.
  constructor.
  constructor.
  apply SR_3_1 with (tau':= (ptype cint)).
  simpl_env.
admit.
  admit.
  constructor.
  admit.
  constructor.
  constructor.
  constructor.
  admit.
  apply_fresh_from SR_3_12 with fv_of_static_goal.
  simpl.
  apply SR_3_1 with (tau':= cint).
  simpl_env.
  constructor.
  constructor.
  constructor.
  auto.
  auto.
  auto.
Qed.

Example pack_int_openstar:
  styp empty LVPE.V.empty ((varx ~ cint) & empty)
       (ptype cint)
       (openstar (pack cint (p_e (fevar varx) nil)
                       (etype aliases B (btvar 0)))
                 (e_s (p_e (fevar varx) nil))).
Proof.
  apply styp_openstar_3_8
  with (L:=\{varx})
         (k:=B)
         (tau':= (btvar 0)).
  simpl.
  intros.
  case_nat.
  constructor.
  apply SR_3_1 with (tau':= (ptype cint)).
  admit.
  auto.
  auto.
  admit. (* WFC won't solve but should be good. *)

  constructor.
  auto.
  admit.
  apply_fresh_from* SR_3_12 with fv_of_static_goal.
  auto.
Qed.
*)

(* Thesis example munged. Pg 62 line 3.
Definition E_62_3 :=
           (pack (ptype cint) (cpair (amp (p_e (fevar varx) nil)) (p_e (fevar varx) nil))
                 (etype aliases B (cross (ptype (btvar 0)) (btvar 0)))).
Example SR_3_12_test:
  rtyp empty LVPE.V.empty ((varx ~ cint) & empty)
    (pack (ptype (cross (ptype cint) cint))
          (cpair (amp (p_e (fevar varx) nil)) (p_e (fevar varx) nil))
          (etype aliases B (ptype (cross (ptype (btvar 0)) (btvar 0)))))
    (etype aliases B (ptype (cross (ptype (btvar 0)) (btvar 0)))).
Proof.
  apply_fresh_from* SR_3_12 with fv_of_static_goal.
  simpl.

Qed.

Example SR_3_12_test:
  rtyp empty LVPE.V.empty empty
       (pack ((cross cint cint) (cpair (i_e (i_i 0)) (i_e (i_i 1)))
             (etype aliases A (ptype (cross (btvar 0) (btvar 0)))))
       (etype aliases A (ptype (cross (btvar 0) (btvar 0)))).
Proof.
  apply_fresh_from SR_3_12 with fv_of_static_goal.
  simpl in Fry.
  simpl.
  auto.
  apply_fresh_from K_etype with fv_of_kinding_goal.
  intros.
  simpl.
  case_nat.
  apply K_B_A.
  apply K_ptype.
  apply K_cross.
  apply K_B_A.
  auto.
Qed.
*)

Example SR_3_13_test:
  rtyp empty LVPE.V.empty empty
       (f_e (dfun cint cint (retn (i_e (i_i 0)))))
       (arrow cint cint).
Proof.
  auto.
(*  apply SR_3_13; *)
Qed.

Example SR_3_14_test:
  rtyp empty LVPE.V.empty empty
       (f_e (ufun B (dfun (btvar 0) (btvar 0) (retn (p_e (bevar 0) nil)))))
       (utype B (arrow (btvar 0) (btvar 0))).
Proof.
  auto.
  (* apply_fresh_from* SR_3_14 with fv_of_static_goal. *)
Qed.

(* Test htyp. *)
Example htyp_empty_test:
  htyp LVPE.V.empty empty empty empty.
Proof.
  apply htyp_empty;
  auto.
Qed.

(* Question: we are at the H & (x~v) & H' match issue. *)
Example htyp_xv_test:
  htyp LVPE.V.empty empty (empty & (varx ~ v) & empty) (empty & (varx ~ tau) & empty).
Proof.
  unfold_test_utilities.
  (* loss of syntax direction here but we don't mind really as eauto is working. *)
  (* auto. *)
  eapply htyp_xv with (g':= empty);
  auto.
  (* Bug needs empty & empty = empty. *)
Admitted.

(* Test refp. *)

Example refp_empty_test:
  refp h LVPE.V.empty.
Proof.
  auto.
  (* apply refp_empty. *)
Qed.

(* BUG
Example refp_pack_test:
  refp [(x,
         pack (cross cint cint)
              (cpair (i_e (i_i 0)) (i_e (i_i 0)))
              (etype aliases alpha A (cross cint cint)))]
       ([((x, [u_pe]), (cross cint cint))] ++ nil).
Proof.
  constructor.
  auto.
  apply refp_pack with
  (k     := A)
  (v     := (cpair (i_e (i_i 0)) (i_e (i_i 0))))
  (v'    := pack (cross cint cint)
                 (cpair (i_e (i_i 0)) (i_e (i_i 0)))
                 (etype aliases alpha A (cross cint cint)))
  (tau   := (cross cint cint))
  (alpha := alpha);
  auto.
  constructor.
  constructor.
  constructor.
  constructor.
  constructor.
   (* Bug, after get(v,nil,v) fix. *)
Admitted.
*)

(* Test prog. *)

Example program_test:
  prog empty (retn (i_e (i_i 0))).
Proof.
  auto.
  apply program with (u:= LVPE.V.empty) (g:= empty) (tau:=cint);
  auto.
Qed.


(* example using semantics *)

Require Export final_sem.
Require Export lambda_reduction.
Require Export interp_coq.
Require Export notations.
Open Scope mmg_scope.

Require Export struct_ex.
Require Export tacticsDed.

(* first example of the tutorial *)
(* binary modes of composition *)
Inductive I:Set:=
a.

(* unary modes of composition*)
(* empty set in that case!*)
Inductive J:Set:=.

(* atomic types *)
Inductive A:Set:=|np|s|n.

Definition eqdecI:eqdec I.
solve_eqdec.
Defined.

Definition eqdecJ:eqdec J.
solve_eqdec.
Defined.

Definition eqdecA:eqdec A.
solve_eqdec.
Defined.

Notation "'!' F":=(At (I:=I) (J:=J) F)(at level 40).
Notation "A '/1' B"
 := (Slash a A B) (at level 42,  left associativity) .

Notation " A '\1' B"
 := (Backslash a A B) (at level 43,  right associativity).

Notation " A 'o1' B"
 := (Dot a A B) (at level 44, right associativity) .

Notation "T1 ,1 T2" :=
(Comma a T1 T2)(at level 45, right associativity).

Notation "A ;1 B":=
(comW a A B)(at level 45, right associativity).
Notation "'#' w":=(oneW I J w)(at level 40).

Notation "h :> ty":=(res h ty)(at level 35).

(* terminals*)
Inductive W:Set:=
|que|la|raison|ignore.

Definition lex(w:W):list ((Form I J  A )*option (lambda_terms logic_cst)):=
match w with
|que=>((!n\1 !n)/1 (!s /1 !np),
(Some ([[e-->t]]: [[e-->t]]: [[e]]: (appl (appl (@ AND) (appl (%1) (%0)))
(appl (%2)(%0))))))::nil
|la => ((!s /1 (!np \1 !s))/1 !n ,
Some ([[e-->t]]: [[e-->t]]: (appl (@EXU) ([[e]]:
 (appl (appl  (@ AND) (appl (%1) (%0))) (appl
(%2)(%0)))))))::nil
|raison=> (!n, None)::nil
|ignore=> ((!np \1 !s)/1 !np, None) ::nil
end.

(* mapping function *)
Definition map (a :A):semType:=
match a with
|n=>e-->t
|np=>e
|s=>t
end.

(* checking the well formedness of our lexicon *)
Lemma wf_lex:isWellTyped_lex map lex.
solve_wf.
Qed.

(* definition of a two dimensitional lexion *)
Definition lex2:lexicon:=mk_lex eqdecI eqdecJ eqdecA wf_lex.

(* definition of the set of structural rules *)
Definition ext:extension I J:=(L2 a) U NL.

Definition gram2:syn_sem_gram:=mk_gram lex2 ext.

(* definition of the expression to be analized *)
Definition clause:=que::la::raison::ignore::nil.

(* proof that the relative clause is a noun modifier:with type
 !n \1 !n *)
(* bottom-up derivation *)
Definition deriv1:||gram2||s: clause >> (!n \1 !n).
addAxioms0.
elimS Ax0 Ax1.
addHyp 0 (!np).
elimS Ax2 Hyp.
elimS H H0.
z_rootH H1.
structL_asc 0 H1.
introS H1.
elimS Ax H.
endDeriv.
Defined.

(* compute the whole semantics*)
(* we obtain a deeply embedded term, not yet reduced *)
Eval compute in (whole_sem deriv1).

(* after reduction *)
Definition nf_deriv1:hasNormalForm (whole_sem deriv1).
solve_nf.
Defined.

Eval compute in (extractNF nf_deriv1).

Definition noHyps:no_hyps_inside (whole_sem deriv1).
compute.
tauto.
Defined.

Definition wt:isWellTyped (type_cst (W:=W)) nil (whole_sem deriv1) (mapExt map (!n\1 !n)).
apply type_check_wellTyped.
compute;auto.
Defined.

Eval compute in (pretty_printer wt noHyps).