(*

-> Section 5.2 in paper
-> Union Types + Null + Intersection Types
-> Intersection introduction
-> Nominal types
-> A * B -> A & B <: Bottom
-> Generalized subtyping for empty types

*)

Require Import TLC.LibLN.
Require Import syntax.
Require Import Program.Equality.
Require Import Coq.Lists.ListSet.
From Coq Require Export Lists.List.
Export ListNotations.

(** definitions *)

(* defns value *)
Inductive value : exp -> Prop :=    (* defn value *)
 | val_int : forall i5,
     value (e_lit i5)
 | val_abs : forall e,
     lc_exp (e_abs e) ->
     value (e_abs e)
 | val_null :
     value e_null
 | val_new  : forall P,
     value  (e_new P).

(* defns FindType *)
Inductive findtype : exp -> typ -> Prop :=    (* defn findtype *)
 | findtype_int : forall i5,
     findtype (e_lit i5) t_int
 | findtype_arrow : forall (e:exp),
     lc_exp (e_abs e) ->
     findtype  (e_abs e) (t_arrow t_top t_bot)
 | findtype_null :
     findtype e_null t_unit
 | find_type_new : forall P,
     findtype (e_new P) (t_prim P).

#[export]
Hint Constructors value findtype : core.

(* defns Typing *)
Reserved Notation "PG , G |- e : A" (at level 80, G at next level, e at next level).
Inductive typing (PG:envp) : env -> exp -> typ -> Prop :=    (* defn typing *)
 | typ_lit : forall (G:env) i5,
      okt  G  ->
      okenvp PG ->
      PG , G |- (e_lit i5) : t_int
 | typ_null : forall G,
      okt G ->
      okenvp PG ->
      typing PG G e_null t_unit
 | typ_var : forall (G:env) (x:var) (A:typ),
      okt  G  ->
      okenvp PG -> wft PG A ->
      binds  x A G  ->
     typing PG G (e_var_f x) A
 | typ_app : forall (G:env) (e1 e2:exp) (B A:typ),
     okenvp PG -> wft PG A -> wft PG B ->
     typing PG G e1 (t_arrow A B) ->
     typing PG G e2 A ->
     typing PG G (e_app e1 e2) B
 | typ_sub : forall (G:env) (e:exp) (A B:typ),
     typing PG G e B ->
     PG |- B <: A ->
     typing PG G e A
 | typ_abs : forall (L:vars) (G:env) (e:exp) (A B:typ),
      okenvp PG -> wft PG A -> wft PG B ->
      ( forall x , x \notin  L  -> typing PG  (G & x ~: A )   ( open_exp_wrt_exp e (e_var_f x) ) B )  ->
     typing PG G (e_abs e) (t_arrow A B)
 | typ_typeof : forall (L:vars) (G:env) (e:exp) (A:typ) (e1:exp) (B:typ) (e2:exp) (C:typ),
     okenvp PG -> wft PG A -> wft PG B -> wft PG C ->
     typing PG G e (t_union A B) ->
     ( forall x , x \notin  L  -> typing PG (G & x ~: A )   ( open_exp_wrt_exp e1 (e_var_f x) ) C ) ->
     ( forall x , x \notin  L  -> typing PG (G & x ~: B )   ( open_exp_wrt_exp e2 (e_var_f x) ) C ) ->
     PG |- A *s B ->
     typing PG G (e_typeof e A e1 B e2) C
 | typ_inter : forall G e A B,
     okenvp PG -> wft PG A -> wft PG B ->
     typing PG G e A ->
     typing PG G e B ->
     typing PG G e (t_and A B)
 | typ_prim : forall i G,
    okt G ->
    okenvp PG -> wft PG (t_prim i) ->
     typing PG G (e_new i) (t_prim i)
where "PG , G |- e : A" := (typing PG G e A).

(* defns Reduction *)
Reserved Notation "PG |- e --> e'" (at level 80, e at next level).
Inductive step (PG: envp) : exp -> exp -> Prop :=    (* defn step *)
 | step_appl : forall (e1 e2 e1':exp),
     lc_exp e2 ->
     PG |- e1 --> e1' ->
     PG |- (e_app e1 e2) --> (e_app e1' e2)
 | step_appr : forall (v e e':exp),
     value v ->
     PG |- e --> e' ->
     PG |- (e_app v e) --> (e_app v e')
 | step_beta : forall (e:exp) (v:exp),
     lc_exp (e_abs e) ->
     value v ->
     PG |- e_app  (e_abs e) v --> (open_exp_wrt_exp e v)
 | step_typeof : forall (e:exp) (A:typ) (e1:exp) (B:typ) (e2 e':exp),
     lc_exp (e_typeof e A e1 B e2) ->
     PG |- e --> e' ->
     PG |- (e_typeof e A e1 B e2) --> (e_typeof e' A e1 B e2)
 | step_typeofl : forall (v:exp) (A:typ) (e1:exp) (B:typ) (e2:exp) (C:typ),
     lc_exp (e_typeof v A e1 B e2) ->
     value v ->
     findtype v C ->
     sub PG C A ->
     PG |- (e_typeof v A e1 B e2) -->  (open_exp_wrt_exp e1 v)
 | step_typeofr : forall (v:exp) (A:typ) (e1:exp) (B:typ) (e2:exp) (C:typ),
    lc_exp (e_typeof v A e1 B e2) ->
     value v ->
     findtype v C ->
     sub PG C B ->
     PG |- (e_typeof v A e1 B e2) -->  (open_exp_wrt_exp  e2 v )
where "PG |- e --> e'" := (step PG e e') : env_scope.

#[export]
Hint Constructors typing step : core.

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

Ltac gather_vars :=
  let A := gather_vars_with (fun x : vars => x) in
  let B := gather_vars_with (fun x : var => \{x}) in
  let D := gather_vars_with (fun x : exp => fv_exp x) in
  let F := gather_vars_with (fun x : env => dom x) in
  constr:(A \u B \u D \u F).

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

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

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

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

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

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

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

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

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

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

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

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

Lemma open_ee_rec_term : forall u e,
  lc_exp e -> forall k, e = open_exp_wrt_exp_rec k u e.
Proof.
  induction 1; intros; simpl; f_equal*.
  unfolds open_exp_wrt_exp. pick_fresh x.
   apply* (@open_ee_rec_term_core e 0 (e_var_f x)).
  unfolds open_exp_wrt_exp. pick_fresh x.
   apply* (@open_ee_rec_term_core e1 0 (e_var_f x)).
  unfolds open_exp_wrt_exp. pick_fresh x.
   apply* (@open_ee_rec_term_core e2 0 (e_var_f x)).
Qed.

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

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

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

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

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

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

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

Lemma subst_ee_intro : forall x u e,
  x \notin fv_exp e -> lc_exp u ->
  open_exp_wrt_exp e u = subst_exp u x (e open_ee_var x).
Proof.
  introv Fr Wu. rewrite* subst_ee_open_ee.
  rewrite* subst_ee_fresh. simpl. case_var*.
Qed.

(** Substitutions preserve local closure. *)

Lemma subst_ee_term : forall e1 Z e2,
lc_exp e1 -> lc_exp e2 -> lc_exp (subst_exp e2 Z e1).
Proof.
  induction 1; intros; simpl; auto.
  case_var*.
 - apply_fresh* lc_e_abs as y.
   rewrite* subst_ee_open_ee_var.
 - apply_fresh* lc_e_typeof as y.
   rewrite* subst_ee_open_ee_var.
   rewrite* subst_ee_open_ee_var.
Qed.

#[export]
Hint Resolve subst_ee_term : core.

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

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

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

#[export]
Hint Extern 1 (ok _) => apply ok_from_okt : core.

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

(** Inversion lemma *)

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

(** Through strengthening *)

Lemma okt_strengthen : forall x T (E F:env),
  okt (E & x ~: T & F) ->
  okt (E & F).
Proof.
  introv O. induction F using env_ind.
  rewrite concat_empty_r in *. apply okt_push_inv in O. destruct~ O.
  rewrite concat_assoc in *.
  apply okt_push_inv in O.
  destruct O. apply IHF in H.
  apply okt_typ; autos*.
Qed.

(** Automation *)

#[export]
Hint Immediate okt_strengthen : core.

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

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

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

Lemma typing_regular : forall PG E e T,
  typing PG E e T -> okt E /\ lc_exp e /\ okenvp PG /\ wft PG T.
Proof.
  induction 1; try splits*.
 - lets (?&WFT1&WFT2): subtyping_regular H0. auto.
 - pick_fresh y. specializes H3 y. destructs~ H3.
  apply okt_push_inv in H3. destruct~ H3.
 - apply lc_e_abs with (L:=L). intros.
  specializes H3 x. destructs~ H3.
 - apply lc_e_typeof with (L:=L); intros.
   destruct IHtyping. destruct~ H10.
   specialize (H5 x H9). destruct H5. destruct~ H10.
   specialize (H7 x H9). destruct H7. destruct~ H10.
Qed.

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

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

#[export]
Hint Immediate value_regular : core.

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

Lemma typing_weakening : forall PG E F G e T,
   typing PG (E & G) e T ->
   okt (E & F & G) ->
   typing PG (E & F & G) e T.
Proof.
  introv Typ. gen F. inductions Typ; introv Ok.
  - apply* typ_lit.
  - apply* typ_null.
  - apply* typ_var. apply* binds_weaken.
  - eapply typ_app. auto. apply H0. auto. auto. auto.
  - apply* typ_sub.
  - eapply typ_abs with (L:=((((L \u fv_exp e) \u dom E) \u dom G) \u dom F)); intros; auto.
    forwards~: (H2 x).
    apply_ih_bind (H3 x); eauto.
  - eapply typ_typeof with (L:=(((((L \u fv_exp e) \u fv_exp e1) \u fv_exp e2) \u dom E) \u dom G) \u dom F); auto; intros.
    forwards~: (H3 x). apply_ih_bind (H4 x); eauto.
    forwards~: (H5 x). apply_ih_bind (H6 x); eauto.
  - apply* typ_inter.
  - apply* typ_prim.
Qed.

(************************************************************************ *)
(** Term Substitution preserves types *)

Require Import Program.Equality.

Lemma typing_through_subst_ee : forall PG E F x T e u U,
   typing PG (E & x ~: U & F) e T ->
   typing PG E u U ->
   typing PG (E & F) (subst_exp u x e) T.
Proof.
introv TypT TypU.
lets TypT': TypT.
inductions TypT; introv; simpl.
(*case int*)
 - apply* typ_lit.
 - (*case null*)
   apply* typ_null.
(*case var*)
 - case_var.
  + binds_get H2.
    lets M: (typing_weakening PG E F empty u U).
    do 2 rewrite concat_empty_r in M.
    apply* M.
  + binds_cases H2; apply* typ_var.
(*case app*)
 - eapply typ_app. auto. apply H0. auto.
   eapply IHTypT1; auto.
   eapply IHTypT2; auto.
(*case sub*)
 - eapply typ_sub. eapply IHTypT; auto. auto.
(*case abs*)
 - eapply typ_abs with (L:=((((L \u \{ x}) \u fv_exp u) \u fv_exp e) \u dom E) \u dom F); intros; auto.
   assert (x0 \notin L) by auto.
   rewrite~ subst_ee_open_ee_var.
   lets TEMP1: H3 x0 H5 E (F & x0 ~: A) x.
   lets TEMP2: TEMP1 U.
   forwards~ : (TEMP1); try solve [rewrite~ concat_assoc]. auto.
   rewrite~ <- concat_assoc.
   apply typing_regular in TypU. destruct TypU. destruct~ H7.
(*case typeof*)
 - eapply typ_typeof with (L:=((((((L \u \{ x}) \u fv_exp u) \u fv_exp e) \u fv_exp e1) \u fv_exp e2) \u
   dom E) \u dom F); intros; auto. eapply IHTypT; auto.
  + assert (x0 \notin L) by auto.
    rewrite~ subst_ee_open_ee_var.
    lets TEMP1: H4 x0 H9 E (F & x0 ~: A) x. lets TEMP2: TEMP1 U.
    forwards~: TEMP2; try solve [rewrite~ concat_assoc].
    rewrite~ <- concat_assoc.
    apply typing_regular in TypU. destruct TypU as [OK [LC _]]. auto.
  + assert (x0 \notin L) by auto.
    rewrite~  subst_ee_open_ee_var.
    lets TEMP1: H6 x0 H9 E (F & x0 ~: B) x. lets TEMP2: TEMP1 U.
    forwards~: TEMP2; try solve [rewrite~ concat_assoc].
    rewrite~ <- concat_assoc.
    apply typing_regular in TypU. destruct TypU as [OK [LC _]]. auto.
 - apply typ_inter; auto.
   eapply IHTypT1; auto.
   eapply IHTypT2; auto.
 - apply typ_prim; auto.
   apply okt_strengthen in H. auto.
Qed.

(* ********************************************************************** *)
(** Typing Inversion Properties *)

Lemma inv_int : forall PG E A i5,
typing PG E (e_lit i5) A -> typing PG E (e_lit i5) t_int /\ sub PG t_int A.
Proof.
  introv Typ.
  inductions Typ.
  (*case typ_int*)
 - split*.
  (*case typ_sub*)
 - specialize (IHTyp i5).
  forwards*: IHTyp. destruct H0.
  split*.
  eapply sub_transitivity; eauto.
  - forwards*: IHTyp1. destruct H2.
    forwards*: IHTyp2.
Qed.

Lemma abs_typ_arrow_sub : forall PG G e A,
typing PG G (e_abs e) A ->
exists A1 B1, sub PG (t_arrow A1 B1) A.
Proof.
    introv Typ.
    inductions Typ.
    - lets* (OK&WFT1&WFT2): subtyping_regular H.
      forwards* (x1&x2&Sub): IHTyp.
      exists x1 x2. eapply sub_transitivity; eauto.
    - exists* A B.
    - forwards* (x1&x2&Sub1): IHTyp1.
      forwards* (x3&x4&Sub2): IHTyp2.
      exists t_top t_bot.
      apply* s_anda.
      forwards* (?&WFT1&WFT2): subtyping_regular Sub1. inverts WFT1.
      assert (sub PG (t_arrow t_top t_bot) (t_arrow x1 x2)); eauto.
      eapply sub_transitivity; eauto.
      forwards* (?&WFT1&WFT2): subtyping_regular Sub2. inverts WFT1.
      assert (sub PG (t_arrow t_top t_bot) (t_arrow x3 x4)); eauto.
      eapply sub_transitivity; eauto.
Qed.

Lemma inv_and_arrow : forall PG G e A1 A2 B1 B2,
  typing PG G (e_abs e) (t_and A1 A2) ->
  sub PG (t_and A1 A2) (t_arrow B1 B2) ->
  sub PG A1 (t_arrow B1 B2) \/ sub PG A2 (t_arrow B1 B2).
Proof.
  introv Typ Sub.
  inverts Sub; eauto.
  apply abs_typ_arrow_sub in Typ; auto.
  destruct Typ as [A3 [A4]].
  apply (findsubtypes_empty_not_ord PG (t_and A1 A2) (t_arrow A3 A4)) in H; auto.
  false. apply H. auto.
  forwards*: subtyping_regular H3.
Qed.

Lemma inv_abs_sub : forall PG G e A B1 B2,
    typing PG G (e_abs e) A ->
    sub PG A (t_arrow B1 B2) ->
         exists C1 C2,
           (exists L, forall x , x \notin  L -> typing PG (G & x ~: C1) (e open_ee_var x) C2)
           /\ sub PG (t_arrow C1 C2) (t_arrow B1 B2).
Proof.
  introv Typ Sub.
  inductions Typ; eauto.
  - assert (HS: sub PG B (t_arrow B1 B2)) by applys sub_transitivity H Sub.
    forwards* (?&?&?&?): IHTyp HS.
  - assert (Typ:(PG, G |- e_abs e : (t_and A B))) by auto.
    lets : inv_and_arrow G Typ Sub. destruct~ H2.
Qed.

Lemma inv_arrow : forall PG G e A1 A2,
    typing PG G (e_abs e) (t_arrow A1 A2) ->
    exists B1 B2, (exists L, forall x , x \notin  L -> typing PG (G & x ~: B1) (e open_ee_var x) B2)
                  /\ sub PG (t_arrow B1 B2) (t_arrow A1 A2).
Proof.
  introv Typ.
  inverts Typ.
  - forwards*: inv_abs_sub H.
  - exists* A1 A2.
Qed.

Lemma inv_abs_union : forall PG G e A A1 A2,
    typing PG G (e_abs e) A ->
    sub PG A (t_union A1 A2) ->
    typing PG G (e_abs e) A1 \/ typing PG G (e_abs e) A2.
Proof.
  introv Typ Sub.
  inductions Typ; eauto.
  - eapply sub_transitivity in Sub; eauto.
  - inverts Sub. clear H6 H7 H8 H3 H10. eauto. eauto.
    inverts H7.
  - inverts Sub; auto.
    clear H5 H6 H8. eauto.
    clear H5 H6 H8. eauto.
    assert (Typ:(PG, G |- e_abs e : (t_and A B))) by auto.
    apply abs_typ_arrow_sub in Typ.
    destruct Typ as [x1 [x2 Sub]].
    lets: ord_sub_findsubtypes_not_empty Sub. auto. contradiction.
Qed.

Lemma inv_null : forall PG E A,
typing PG E e_null A -> typing PG E e_null t_unit /\ sub PG t_unit A.
Proof.
  introv Typ.
  inductions Typ.
  (*case typ_int*)
 - split*.
  (*case typ_sub*)
 - forwards*: IHTyp. destruct H0.
   split*.
   eapply sub_transitivity; eauto.
 - forwards*: IHTyp1.
Qed.

Lemma inv_P : forall PG E P A,
typing PG E (e_new P) A -> typing PG E (e_new P) (t_prim P) /\ sub PG (t_prim P) A.
Proof.
  introv Typ.
  inductions Typ.
  (*case typ_int*)
 - forwards*: IHTyp. destruct H0.
   split*.
   eapply sub_transitivity; eauto.
  (*case typ_sub*)
 - forwards*: IHTyp1.
   forwards*: IHTyp2.
   forwards*: subtyping_regular H2.
 - split*.
Qed.

Lemma check_or_typ : forall PG E e A B,
   value e ->
   typing PG E e (t_union A B) ->
   typing PG E e A \/ typing PG E e B.
Proof.
  introv Val Typ.
  inverts Val.
  (*subsumption again*)
 - apply inv_int in Typ. destruct Typ.
   inverts H0. left*. right*. inverts H4.
 - inverts Typ.
   eapply inv_abs_union in H0; eauto.
 - apply inv_null in Typ. destruct Typ.
   inverts H0. left*. right*. inverts H4.
 - apply inv_P in Typ; auto. destruct Typ.
   inverts H0. left*. right*. inverts H4.
Qed.

Lemma val_check_disjoint_types : forall PG E v A B,
PG |- A *s B ->
value v ->
typing PG E v A ->
typing PG E v B -> False.
Proof.
  introv Disj Val Typ1 Typ2.
  unfold DisjSpec in Disj. unfold not in Disj.
  inverts Val.
  - apply inv_int in Typ1; auto. destruct Typ1.
    apply inv_int in Typ2; auto. destruct Typ2.
    forwards*(?&WFT1&WFT2): subtyping_regular H2.
    forwards*(?&WFT11&WFT21): subtyping_regular H0.
  - apply abs_typ_arrow_sub in Typ1; auto.
    destruct Typ1 as [A1 [B1]].
    lets (?&WFT1&WFT2): subtyping_regular H0. inverts WFT1.
    assert (sub PG (t_arrow t_top t_bot) (t_arrow A1 B1)); auto.
    apply abs_typ_arrow_sub in Typ2; auto.
    destruct Typ2 as [A2 [B2]].
    lets(?&WFT3&WFT4): subtyping_regular H3. inverts WFT3.
    assert (sub PG (t_arrow t_top t_bot) (t_arrow A2 B2)). auto.
    eapply sub_transitivity with (A:=(t_arrow t_top t_bot)) (B:=(t_arrow A1 B1)) (C:=A) in H2; auto.
    eapply sub_transitivity with (A:=(t_arrow t_top t_bot)) (B:=(t_arrow A2 B2)) (C:=B) in H7; auto.
    forwards*: Disj (t_arrow t_top t_bot).
  - apply inv_null in Typ1; auto. destruct Typ1.
    apply inv_null in Typ2; auto. destruct Typ2.
    lets(?&WFT1&WFT2): subtyping_regular H2.
    lets(?&WFT3&WFT4): subtyping_regular H0.
    forwards*: Disj t_unit.
  - apply inv_P in Typ1; auto. destruct Typ1.
    apply inv_P in Typ2; auto. destruct Typ2.
    lets(?&WFT1&WFT2): subtyping_regular H2.
    lets(?&WFT3&WFT4): subtyping_regular H0.
    forwards*: Disj (t_prim P).
Qed.

Lemma check_find_type : forall PG E e A B,
typing PG E e A ->
findtype e B ->
sub PG B A.
Proof.
  introv Typ Find.
  inductions Find.
  - apply inv_int in Typ; auto.
    destruct~ Typ.
  - apply abs_typ_arrow_sub in Typ; auto.
    destruct Typ as [A1 [B1]].
    lets(?&WFT1&WFT2): subtyping_regular H0. inverts WFT1.
    assert (sub PG (t_arrow t_top t_bot) (t_arrow A1 B1)) by auto.
    eapply sub_transitivity; eauto.
  - apply inv_null in Typ; auto. destruct~ Typ.
  - apply inv_P in Typ; auto. destruct Typ. auto.
Qed.

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

(* Theorem 7 *)

Lemma preservation : forall PG E e e' T,
  typing PG E e T ->
  PG |- e --> e' ->
  typing PG E e' T.
Proof.
  introv Typ. gen e'.
  inductions Typ; introv Red; try solve [ inverts Red ].
  - (* app *)
    inverts Red.
    eapply typ_app. auto. apply H0. auto.
    apply IHTyp1; auto. auto.
    eapply typ_app. auto. apply H0. auto. auto.
    apply IHTyp2. auto.
    (* beta *)
        forwards (A1&B1&TEMP1&Sub): inv_arrow Typ1.
        destruct TEMP1 as [L TEMP2].
        pick_fresh x.
        assert (NOTIN: (x \notin L)) by auto.
        lets TEMP3: TEMP2 x NOTIN.
        assert (EQ: (G & x ~: A1 = G & x ~: A1 & empty)).
        rewrite* concat_empty_r.
        rewrite EQ in TEMP3.
        assert (EQ2: (G = G & empty)).
        rewrite* concat_empty_r. rewrite EQ2.
        lets TEMP4: typing_through_subst_ee.
        inverts Sub.
        lets TEMP5: typ_sub Typ2 H13. clear Typ2.
        forwards: TEMP4 TEMP3 TEMP5.
        rewrite* (@subst_ee_intro x).
        inverts H7.
  - (*case subsumption*)
    inverts* Red.
  - (* typeof *)
    inverts Red.
    + eapply typ_typeof with (L:=L); auto.
    + (* value checks against disjoint types *)
      lets temp1: check_or_typ PG G e A B.
      lets DisjOr: temp1 H15 Typ.
      destruct DisjOr.
     * (*true goal*)
       pick_fresh y. assert (NOTIN: (y \notin L)) by auto.
       forwards temp2: H3 NOTIN.
       assert  (EQ1: (G & y ~: A = G & y ~: A & empty)).
       rewrite* concat_empty_r. rewrite EQ1 in temp2.
       assert (temp3: (G = G & empty)).
       rewrite* concat_empty_r.
       rewrite temp3.
       lets temp4: typing_through_subst_ee PG temp2 H8.
       rewrite* (@subst_ee_intro y).
     * (*false goal, value e checks against disjoint types A and B*)
       lets temp2: check_find_type PG G e B C0.
       lets SubB: temp2 H8 H16.
       unfold DisjSpec in H7. unfold not in H7.
       destruct H16.
       forwards FF: H7 t_int; auto; inverts FF.
       forwards FF: H7 (t_arrow t_top t_bot); auto; inverts FF.
       forwards FF: H7 t_unit; auto; inverts FF.
       forwards (_&WFT&_) : subtyping_regular H17.
       forwards FF: H7 (t_prim P); auto; inverts FF.
    +  (* value checks against disjoint types *)
      lets temp: check_or_typ PG G e A B.
      lets DisjOr: temp H15 Typ.
      destruct DisjOr.
     * (*false goal, value e checks against disjoint types A and B*)
        lets temp1: check_find_type PG G e A C0.
        lets SubA: temp1 H8 H16.
        unfold DisjSpec in H7. unfold not in H7.
        destruct H16.
        forwards FF: H7 t_int; auto; inverts FF.
        forwards FF: H7 (t_arrow t_top t_bot); auto; inverts FF.
        forwards FF: H7 t_unit; auto; inverts FF.
        forwards (_&WFT&_): subtyping_regular SubA.
        forwards FF: H7 (t_prim P); auto; inverts FF.
     * (*true goal*)
        pick_fresh y. assert (NOTIN: (y \notin L)) by auto.
        forwards temp2: H5 NOTIN.
        assert  (EQ1: (G & y ~: B = G & y ~: B & empty)).
        rewrite* concat_empty_r. rewrite EQ1 in temp2.
        assert (EQ2: (G = G & empty)).
        rewrite* concat_empty_r.
        rewrite EQ2.
        lets : typing_through_subst_ee PG temp2 H8.
        rewrite* (@subst_ee_intro y).
    - forwards*: IHTyp1.
Qed.

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

(* Theorem 8 *)

Lemma progress : forall PG e T,
typing PG empty e T -> (value e) \/ (exists e', PG |- e --> e').
Proof.
introv Typ. gen_eq E: (@empty typ). lets Typ': Typ.
inductions Typ; intros EQ; subst.
(*case int*)
 - left*.
 (*case null*)
 - left*.
 (*case var*)
 - apply binds_empty_inv in H2. inversion H2.
 (*case typ-app*)
 - right. destruct* IHTyp1.
  + destruct* IHTyp2.
   * inverts* H2.
     (*false cases infers arrow*)
     apply inv_int in Typ1; auto.
     destruct Typ1 as [_ Sub].
     inverts Sub. inverts H6.
     apply inv_null in Typ1; auto.
     destruct Typ1 as [_ Sub].
     inverts Sub. inverts H6.
     apply inv_P in Typ1; auto.
     destruct Typ1 as [_ Sub].
     inverts Sub. inverts H6.
     (*case step-appl*)
   * destruct H3 as [x temp1].
     exists* (e_app e1 x).
   (*case step-appr*)
  + destruct H2 as [x temp1].
    exists (e_app x e2). apply* step_appl.
    forwards*: typing_regular Typ2.
(*case typ-sub*)
 - destruct~ IHTyp.
(*case typ-abs*)
 - left. forwards*: typing_regular Typ'.
(*case typ-typeof*)
 - right. destruct* IHTyp.
  + apply check_or_typ in Typ; auto.
    destruct Typ.
    (*case typeofl*)
   * destruct H8.
     { (*case e = int*)
      apply inv_int in H9; auto. destruct H9.
      exists (open_exp_wrt_exp e1 (e_lit i5)).
      pick_fresh y.
      assert (NOTIN: (y \notin L)) by auto.
      lets: H3 y NOTIN.
      eapply step_typeofl with (C:=t_int); eauto.
      forwards*: typing_regular Typ'.
     }
     { (*case e = \x.e*)
      apply abs_typ_arrow_sub in H9; auto.
      destruct H9 as [A1 [B1]].
      lets(_&WFT1&_): subtyping_regular H9. inverts WFT1.
      assert (sub PG (t_arrow t_top t_bot) (t_arrow A1 B1)) by auto.
      eapply sub_transitivity in H9; eauto.
      exists (open_exp_wrt_exp e1 (e_abs e)).
      pick_fresh y.
      assert (NOTIN: (y \notin L)) by auto.
      lets temp1: H3 y NOTIN.
      eapply step_typeofl with (C:=(t_arrow t_top t_bot)); eauto.
      forwards*: typing_regular Typ'.
     }
     {
       (*case e = null*)
       apply inv_null in H9; auto. destruct H9.
       exists (open_exp_wrt_exp e1 e_null).
       pick_fresh y.
       assert (NOTIN: (y \notin L)) by auto.
       lets: H3 y NOTIN.
       eapply step_typeofl with (C:=t_unit); eauto.
       forwards*: typing_regular Typ'.
     }
     {
       apply inv_P in H9; auto. destruct H9.
       exists (open_exp_wrt_exp e1 (e_new P)).
       pick_fresh y.
       assert (NOTIN: (y \notin L)) by auto.
       lets: H3 y NOTIN.
       eapply step_typeofl with (C:=(t_prim P)); eauto.
       forwards*: typing_regular Typ'.
     }
   * (*case typeofr*)
     destruct H8.
     apply inv_int in H9; auto. destruct H9.
     { (*case e = int*)
      exists (open_exp_wrt_exp e2 (e_lit i5)).
      pick_fresh y.
      assert (NOTIN: (y \notin L)) by auto.
      lets: H5 y NOTIN.
      eapply step_typeofr with (C:=t_int); eauto.
      forwards*: typing_regular Typ'.
     }
     { (*case e = \x.e*)
      apply abs_typ_arrow_sub in H9; auto.
      destruct H9 as [A1 [B1]].
      lets(_&WFT1&_): subtyping_regular H9. inverts WFT1.
      assert (sub PG (t_arrow t_top t_bot) (t_arrow A1 B1)) by auto.
      eapply sub_transitivity in H9; eauto.
      exists (open_exp_wrt_exp e2 (e_abs e)).
      pick_fresh y.
      assert (NOTIN: (y \notin L)) by auto.
      lets: H5 y NOTIN.
      eapply step_typeofr with (C:=(t_arrow t_top t_bot)); eauto.
      forwards*: typing_regular Typ'.
     }
     { (*case e = null*)
       apply inv_null in H9; auto. destruct H9.
       exists (open_exp_wrt_exp e2 e_null).
       pick_fresh y.
       assert (NOTIN: (y \notin L)) by auto.
       lets: H5 y NOTIN.
       eapply step_typeofr with (C:=t_unit); eauto.
       forwards*: typing_regular Typ'.
     }
     {
      apply inv_P in H9; auto. destruct H9.
      exists (open_exp_wrt_exp e2 (e_new P)).
      pick_fresh y.
      assert (NOTIN: (y \notin L)) by auto.
      lets: H5 y NOTIN.
      eapply step_typeofr with (C:=(t_prim P)); eauto.
      forwards*: typing_regular Typ'.
     }
  + (*case typeof*)
    destruct H8 as [x temp].
    exists (e_typeof x A e1 B e2).
    apply step_typeof; auto.
    forwards*: typing_regular Typ'.
  - destruct~ IHTyp1.
  - left*.
    (* we make e_new a value? *)
Qed.

(* ********************************************************************** *)
(** More Typing Inversion Properties *)

Lemma inv_app : forall PG E e1 e2 A,
typing PG E (e_app e1 e2) A ->
exists A1 B1, typing PG E e1 (t_arrow A1 B1) /\ typing PG E e2 A1.
Proof.
  introv Typ.
  inductions Typ.
 - exists* A B.
 - specialize (IHTyp e1 e2).
  forwards*: IHTyp.
 - forwards*: IHTyp1.
Qed.

Lemma inv_typeof : forall PG E e e1 e2 A B C,
typing PG E (e_typeof e A e1 B e2) C ->
exists D, typing PG E e D /\ PG |- A *s B.
Proof.
  introv Typ.
  inductions Typ.
  - specialize (IHTyp e e1 e2 A B).
    forwards*: IHTyp.
  - exists* (t_union A B).
  - forwards*: IHTyp1.
Qed.

(*******************************)
(*****  Determinism Lemma  *****)
(*******************************)

(* Theorem 10 *)

Lemma determinism : forall PG E e e1 e2 A, typing PG E e A ->
PG |- e --> e1 -> PG |- e --> e2 -> e1 = e2.
Proof.
  introv Typ He1. gen e2 A.
  induction He1; introv Typ He2.
  (*case step-appl*)
  - inverts* He2.
   + apply inv_app in Typ.
     destruct Typ as [A1 [B1]]. destruct H0.
     forwards*: IHHe1. rewrite* H3.
   + inverts* H2; inverts He1.
   + inverts* He1.
(*case step-appr*)
  - inverts* He2.
   + inverts* H; inverts* H4.
   + apply inv_app in Typ.
     destruct Typ as [A1 [B1]]. destruct H0.
     forwards*: IHHe1 H1. rewrite* H3.
   + inverts H4; inverts He1.
(*case step-beta*)
  - inverts* He2.
   + inverts* H5.
   + inverts H0; inverts H5.
(*case step-typeof*)
 - inverts* He2.
  + apply inv_typeof in Typ.
    destruct Typ as [D]. destruct H0.
    forwards*: IHHe1. rewrite* H2.
  + inverts H8; inverts He1.
  + inverts H8; inverts He1.
(*case step-typeofl*)
 - inverts* He2.
  + inverts H0. inverts H10. inverts H10. inverts H10. inverts H10.
  + apply inv_typeof in Typ.
    destruct Typ as [D]. destruct H3 as [H3 Disj].
    inverts H0.
    * inverts H1.
      inverts H11.
      unfold DisjSpec in Disj. unfold not in Disj.
      lets(OK&WFT1&WFT2): subtyping_regular H12.
      lets(?&WFT3&WFT4): subtyping_regular H2.
      forwards*: Disj t_int.
    * inverts H1.
      inverts H11.
      unfold DisjSpec in Disj. unfold not in Disj.
      lets(?&WFT1&WFT2): subtyping_regular H2.
      lets(?&WFT3&WFT4): subtyping_regular H12.
      forwards*: Disj (t_arrow t_top t_bot).
    * inverts H1. inverts H11.
      forwards*: Disj t_unit.
      lets(?&WFT1&WFT2): subtyping_regular H2.
      lets(?&WFT3&WFT4): subtyping_regular H12.
      assert (sub PG t_unit (t_and A B)) by auto.
      contradiction.
    * inverts H1. inverts H11.
    lets(?&WFT1&WFT2): subtyping_regular H2.
    lets(?&WFT3&WFT4): subtyping_regular H12.
      assert (PG |- (t_prim P) <: (t_and A B)) by auto.
      forwards*: Disj (t_prim P).
(*case step-typeofr*)
- inverts* He2.
  + inverts H0; inverts H10.
  + apply inv_typeof in Typ.
    destruct Typ as [D]. destruct H3 as [H3 Disj].
    lets(?&WFT1&WFT2): subtyping_regular H2.
    lets(?&WFT3&WFT4): subtyping_regular H12.
    inverts H0.
    * inverts H1.
      inverts H11.
      unfold DisjSpec in Disj. unfold not in Disj.
      forwards*: Disj t_int.
    * inverts H1.
      inverts H11.
      unfold DisjSpec in Disj. unfold not in Disj.
      forwards*: Disj (t_arrow t_top t_bot).
    * inverts H1. inverts H11.
      forwards*: Disj t_unit.
      assert (sub PG t_unit (t_and A B)) by auto.
      contradiction.
    * inverts H1. inverts H11.
      assert (PG |- (t_prim P) <: (t_and A B)) by auto.
      forwards*: Disj (t_prim P).
Qed.

(**************************************************)
(* Lemma: Intersection Types Disjoint *)

Lemma intersection_type_disjointness :
  forall PG A B C,
  okenvp PG -> wft PG A ->
  wft PG B -> wft PG C ->
  DisjSpec PG A C \/ DisjSpec PG B C ->
  DisjSpec PG (t_and A B) C.
Proof.
  introv Ok WFA WFB WFC Disj.
  unfold DisjSpec in *. unfold not in *.
  destruct Disj as [Disj | Disj]; introv ORD SUB.
  apply sub_and in SUB. destruct SUB.
  apply sub_and in H. destruct H.
  forwards*: subtyping_regular H0.
  apply sub_and in SUB. destruct SUB.
  apply sub_and in H. destruct H.
  forwards*: subtyping_regular H0.
Qed.


Set Implicit Arguments.

Require Import Coq.Lists.List
        Coq.Program.Program
        Coq.Arith.Arith
        Coq.Strings.String.
Require Import
        Fiat.ADT
        Fiat.ADT.ComputationalADT
        Fiat.ADTNotation
        Fiat.ADTRefinement
        Fiat.ADTRefinement.BuildADTRefinements
        Fiat.Fiat4Monitors.RADL_Topics
        Fiat.Fiat4Monitors.RADL_Messages
        Fiat.Fiat4Monitors.RADL_Flags
        Fiat.Fiat4Monitors.RADL_Nodes.
Require Import Bedrock.Platform.Facade.DFacade
        Bedrock.Platform.Facade.Notations
        Bedrock.Platform.Cito.ADT
        Bedrock.Platform.Cito.RepInv.

Ltac crush_types :=
  unfold type_conforming, same_types, same_type; intros;
  repeat match goal with
         | [ H: exists t, _ |- _ ] => destruct H
         end; subst;
  intuition.

Section RADL_NodeADTs.
  (* Each of these structs is represented in Facade as a distinct ADT. *)

  Context {n : nat}.
  Variable TopicTypes : Vector.t Type n. (* List of Topics in the Network. *)
  Variable TopicNames : Vector.t string n. (* List of Topics IDs in the Network. *)

  Context {n' : nat}.
  Variable subtopics : Vector.t (Fin.t n) n'. (* List of Topics in the Network. *)
  Variable Node : RADL_Node (n := n). (* The Node we're modelling. *)

  (* The mathematical model of the node's internal state. *)
  Variable Node_Rep : Type.

  Inductive RADL_Node_ADTValues : Type :=
  | Message_In : cRep (radl_in_t TopicTypes TopicNames Node) -> RADL_Node_ADTValues
  | Message_Out : cRep (radl_out_t TopicTypes TopicNames Node) -> RADL_Node_ADTValues
  | Message_In_Flags :  cRep (radl_in_flags_t TopicNames Node) -> RADL_Node_ADTValues
  | Message_Out_Flags : cRep (radl_out_flags_t TopicNames Node) -> RADL_Node_ADTValues
  | Flag : RADL_Flag -> RADL_Node_ADTValues
  | RADL_Node : Node_Rep -> RADL_Node_ADTValues.

  (* Specs for getters and setters for each message type . *)
  Section Message_In_Specs.
    (* Coercions for getter domain and codomain values. *)
    Let topics := RADL_Subscriptions Node.
    Variable idx : Fin.t (RADL_NumSubscriptions Node).
    Variable Get_In_DomMap
      : unit -> fst (MethodDomCod (MessageADTSig TopicTypes TopicNames topics)
                                  (ibound (indexb (BuildGetMessageMethodID TopicTypes TopicNames topics idx)))).
    Variable Get_In_CodMap
      : snd (MethodDomCod (MessageADTSig TopicTypes TopicNames topics)
                          (ibound (indexb (BuildGetMessageMethodID TopicTypes TopicNames topics idx))))
        -> Memory.W.
    Definition Message_In_GetSpec
    : AxiomaticSpec RADL_Node_ADTValues.
      refine {|
          PreCond args := exists msg, args = [ADT (Message_In msg)];
          PostCond args ret :=
            exists msg, args = [(ADT (Message_In msg),
                                 Some (Message_In msg)) ] /\
                        ret = SCA _
                                  (Get_In_CodMap (snd (CallMessageGetMethod _ _ _ msg idx (Get_In_DomMap tt))))
        |}; crush_types.
    Defined.

    (* Coercions for setter domain and codomain values. *)
    Variable Set_In_CodMap
      : Memory.W ->
        fst (MethodDomCod (MessageADTSig TopicTypes TopicNames topics)
                          (ibound (indexb (BuildSetMessageMethodID TopicTypes TopicNames topics idx)))).
    Definition Message_In_SetSpec
    : AxiomaticSpec RADL_Node_ADTValues.
      refine {|
          PreCond args := exists msg w, args = [ADT (Message_In msg), SCA _ w];
          PostCond args ret :=
            exists msg w, args = [(ADT (Message_In msg),
                                   Some (Message_In (fst (CallMessageSetMethod _ _ _ msg idx (Set_In_CodMap w))))),
                                  (SCA _ w, None)
                                 ]
        |}; crush_types.
    Defined.
  End Message_In_Specs.

  Section Message_In_Flags_Specs.
    (* Coercions for getter domain and codomain values. *)
    Let topics := RADL_Subscriptions Node.
    Variable idx : Fin.t (RADL_NumSubscriptions Node).
    Variable Get_In_DomMap
      : unit -> fst (MethodDomCod (FlagsADTSig TopicNames topics)
                                  (ibound (indexb (BuildGetFlagsMethodID TopicNames topics idx)))).
    Variable Get_In_CodMap
      : snd (MethodDomCod (FlagsADTSig TopicNames topics)
                          (ibound (indexb (BuildGetFlagsMethodID TopicNames topics idx))))
        -> Memory.W.

    Definition Message_In_Flags_GetSpec
    : AxiomaticSpec RADL_Node_ADTValues.
      refine {|
          PreCond args := exists msg, args = [ADT (Message_In_Flags msg)];
          PostCond args ret :=
            exists msg, args = [(ADT (Message_In_Flags msg),
                                 Some (Message_In_Flags msg)) ] /\
                        ret = SCA _
                                  (Get_In_CodMap (snd (CallFlagsGetMethod _ msg idx (Get_In_DomMap tt))))
        |}; crush_types.
    Defined.

    (* Coercions for setter domain and codomain values. *)
    Variable Set_In_CodMap
      : Memory.W -> fst
                      (MethodDomCod (FlagsADTSig TopicNames topics)
                                    (ibound (indexb (BuildSetFlagsMethodID TopicNames topics idx)))).

    Definition Message_In_Flags_SetSpec
    : AxiomaticSpec RADL_Node_ADTValues.
      refine {|
          PreCond args := exists msg w, args = [ADT (Message_In_Flags msg), SCA _ w];
          PostCond args ret :=
            exists msg w, args = [(ADT (Message_In_Flags msg),
                                   Some (Message_In_Flags (fst (CallFlagsSetMethod _ msg idx (Set_In_CodMap w))))),
                                  (SCA _ w, None)
                                 ]
        |}; crush_types.
    Defined.
  End Message_In_Flags_Specs.

  Section Message_Out_Specs.
    (* Coercions for getter domain and codomain values. *)
    Let topics := RADL_Publications Node.
    Variable idx : Fin.t (RADL_NumPublications Node).
    Variable Get_In_DomMap
      : unit -> fst (MethodDomCod (MessageADTSig TopicTypes TopicNames topics)
                                  (ibound (indexb (BuildGetMessageMethodID TopicTypes TopicNames topics idx)))).
    Variable Get_In_CodMap
      : snd (MethodDomCod (MessageADTSig TopicTypes TopicNames topics)
                          (ibound (indexb (BuildGetMessageMethodID TopicTypes TopicNames topics idx))))
        -> Memory.W.

    Definition Message_Out_GetSpec
    : AxiomaticSpec RADL_Node_ADTValues.
      refine {|
          PreCond args := exists msg, args = [ADT (Message_Out msg)];
          PostCond args ret :=
            exists msg, args = [(ADT (Message_Out msg),
                                 Some (Message_Out msg)) ] /\
                        ret = SCA _
                                  (Get_In_CodMap (snd (CallMessageGetMethod _ _ _ msg idx (Get_In_DomMap tt))))
        |}; crush_types.
    Defined.

    (* Coercions for setter domain and codomain values. *)
    Variable Set_In_CodMap
      : Memory.W ->
        fst (MethodDomCod (MessageADTSig TopicTypes TopicNames topics)
                          (ibound (indexb (BuildSetMessageMethodID TopicTypes TopicNames topics idx)))).
    Definition Message_Out_SetSpec
    : AxiomaticSpec RADL_Node_ADTValues.
      refine {|
          PreCond args := exists msg w, args = [ADT (Message_Out msg), SCA _ w];
          PostCond args ret :=
            exists msg w, args = [(ADT (Message_Out msg),
                                   Some (Message_Out (fst (CallMessageSetMethod _ _ _ msg idx (Set_In_CodMap w))))),
                                  (SCA _ w, None)
                                 ]
        |}; crush_types.
    Defined.
  End Message_Out_Specs.

  Section Message_Out_Flags_Specs.
    (* Coercions for getter domain and codomain values. *)
    Let topics := RADL_Publications Node.
    Variable idx : Fin.t (RADL_NumPublications Node).
    Variable Get_Out_DomMap
      : unit -> fst (MethodDomCod (FlagsADTSig TopicNames topics)
                                  (ibound (indexb (BuildGetFlagsMethodID TopicNames topics idx)))).
    Variable Get_Out_CodMap
      : snd (MethodDomCod (FlagsADTSig TopicNames topics)
                          (ibound (indexb (BuildGetFlagsMethodID TopicNames topics idx))))
        -> Memory.W.

    Definition Message_Out_Flags_GetSpec
    : AxiomaticSpec RADL_Node_ADTValues.
      refine {|
          PreCond args := exists msg, args = [ADT (Message_Out_Flags msg)];
          PostCond args ret :=
            exists msg, args = [(ADT (Message_Out_Flags msg),
                                 Some (Message_Out_Flags msg)) ] /\
                        ret = SCA _
                                  (Get_Out_CodMap
                                                  (snd (CallFlagsGetMethod _ msg idx (Get_Out_DomMap tt))))
        |}; crush_types.
    Defined.

    (* Coercions for setter domain and codomain values. *)
    Variable Set_Out_CodMap
      : Memory.W -> fst
                      (MethodDomCod (FlagsADTSig TopicNames topics)
                                    (ibound (indexb (BuildSetFlagsMethodID TopicNames topics idx)))).

    Definition Message_Out_Flags_SetSpec
    : AxiomaticSpec RADL_Node_ADTValues.
      refine {|
          PreCond args := exists msg w, args = [ADT (Message_Out_Flags msg), SCA _ w];
          PostCond args ret :=
            exists msg w, args = [(ADT (Message_Out_Flags msg),
                                   Some (Message_Out_Flags (fst (CallFlagsSetMethod _ msg idx (Set_Out_CodMap w))))),
                                  (SCA _ w, None)
                                 ]
        |}; crush_types.
    Defined.
  End Message_Out_Flags_Specs.

End RADL_NodeADTs.


Require Import Raft.
Require Import RaftRefinementInterface.

Section VotedForTermSanity.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition votedFor_term_sanity (net : network) : Prop :=
    forall t h h',
      currentTerm (snd (nwState net h')) = t ->
      votedFor (snd (nwState net h')) = Some h ->
      t <= currentTerm (snd (nwState net h)).

  Class votedFor_term_sanity_interface : Prop :=
    {
      votedFor_term_sanity_invariant :
        forall net,
          refined_raft_intermediate_reachable net ->
          votedFor_term_sanity net
    }.
End VotedForTermSanity.


Require Import ExtLib.Structures.Applicative.

Set Implicit Arguments.
Set Maximal Implicit Insertion.

Polymorphic Class Traversable@{d r} (T : Type@{d} -> Type@{r}) : Type :=
{ mapT : forall {F : Type@{d} -> Type@{r} }
                {Ap:Applicative@{d r} F} {A B : Type@{d}},
    (A -> F B) -> T A -> F (T B)
}.

Polymorphic Definition sequence@{d r}
            {T : Type@{d} -> Type@{d}}
            {Tr:Traversable T}
            {F : Type@{d} -> Type@{d}} {Ap:Applicative F} {A : Type@{d}}
  : T (F A) -> F (T A) := mapT (@id _).

Polymorphic Definition forT@{d r}
            {T : Type@{d} -> Type@{d}}
            {Tr:Traversable T} {F : Type@{d} -> Type@{d}} {Ap:Applicative F}
            {A B : Type@{d}} (aT:T A) (f:A -> F B) : F (T B)
:= mapT f aT.


From Autosubst Require Export Autosubst.
From iris.program_logic Require Export language ectx_language ectxi_language.
From fae_gtlc_mu.cast_calculus Require Export types types_lemmas.

(** Expressions *)
Inductive expr :=
| Var (x : var)
| Lam (e : {bind 1 of expr})
| App (e1 e2 : expr)
(* Base types *)
| Unit
(* Products *)
| Pair (e1 e2 : expr)
| Fst (e : expr)
| Snd (e : expr)
(* Sums *)
| InjL (e : expr)
| InjR (e : expr)
| Case (e0 : expr) (e1 : {bind expr}) (e2 : {bind expr})
(* Recursive Types *)
| Fold (e : expr)
| Unfold (e : expr)
(* Casts! *)
| Cast (e : expr) (τi τf : type)
| CastError.

Coercion App : expr >-> Funclass.

Instance Ids_expr : Ids expr. derive. Defined.
Instance Rename_expr : Rename expr. derive. Defined.
Instance Subst_expr : Subst expr. derive. Defined.
Instance SubstLemmas_expr : SubstLemmas expr. derive. Qed.

(** Values *)
Inductive val :=
| LamV (e : {bind 1 of expr})
| UnitV
| PairV (v1 v2 : val)
| InjLV (v : val)
| InjRV (v : val)
| FoldV (v : val)
| CastV (v : val) (τi τf : type) (Ip : ICP τi τf).

Fixpoint of_val (v : val) : expr :=
  match v with
  | LamV e => Lam e
  | UnitV => Unit
  | PairV v1 v2 => Pair (of_val v1) (of_val v2)
  | InjLV v => InjL (of_val v)
  | InjRV v => InjR (of_val v)
  | FoldV v => Fold (of_val v)
  | CastV v τi τf Ip => Cast (of_val v) τi τf
  end.
(* Notation "# v" := (of_val v) (at level 20). *)

Coercion of_val : val >-> expr.

Fixpoint to_val (e : expr) : option val :=
  match e with
  | Lam e => Some (LamV e)
  | Unit => Some UnitV
  | Pair e1 e2 => v1 ← to_val e1; v2 ← to_val e2; Some (PairV v1 v2)
  | InjL e => InjLV <$> to_val e
  | InjR e => InjRV <$> to_val e
  | Fold e => v ← to_val e; Some (FoldV v)
  | Cast e τi τf => match (ICP_dec τi τf) with
                     | left Ip => v ← to_val e; Some (CastV v τi τf Ip)
                     | right _ => None
                   end
  | Var _ => None
  | App _ _ => None
  | Fst _ => None
  | Snd _ => None
  | Case _ _ _ => None
  | Unfold _ => None
  | CastError => None
  end.

(** Evaluation contexts of depth 1 *)
Inductive ectx_item :=
| AppLCtx (e2 : expr)
| AppRCtx (v1 : val)
| PairLCtx (e2 : expr)
| PairRCtx (v1 : val)
| FstCtx
| SndCtx
| InjLCtx
| InjRCtx
| CaseCtx (e1 : {bind expr}) (e2 : {bind expr})
| FoldCtx
| UnfoldCtx
| CastCtx (τi τf : type).

Definition fill_item (Ki : ectx_item) (e : expr) : expr :=
  match Ki with
  | AppLCtx e2 => App e e2
  | AppRCtx v1 => App (of_val v1) e
  | PairLCtx e2 => Pair e e2
  | PairRCtx v1 => Pair (of_val v1) e
  | FstCtx => Fst e
  | SndCtx => Snd e
  | InjLCtx => InjL e
  | InjRCtx => InjR e
  | CaseCtx e1 e2 => Case e e1 e2
  | FoldCtx => Fold e
  | UnfoldCtx => Unfold e
  | CastCtx τi τf => Cast e τi τf
  end.

Definition state : Type := ().

(** Head steps *)
Inductive head_step : expr → expr → Prop :=
(* β *)
| BetaS e1 e2 v2:
    to_val e2 = Some v2 →
    head_step (App (Lam e1) e2) e1.[e2/]
(* Products *)
| FstS e1 v1 e2 v2:
    to_val e1 = Some v1 → to_val e2 = Some v2 →
    head_step (Fst (Pair e1 e2)) e1
| SndS e1 v1 e2 v2:
    to_val e1 = Some v1 → to_val e2 = Some v2 →
    head_step (Snd (Pair e1 e2)) e2
(* Sums *)
| CaseLS e0 v0 e1 e2:
    to_val e0 = Some v0 →
    head_step (Case (InjL e0) e1 e2) e1.[e0/]
| CaseRS e0 v0 e1 e2:
    to_val e0 = Some v0 →
    head_step (Case (InjR e0) e1 e2) e2.[e0/]
(* Recursive Types *)
| Unfold_Fold e v:
    to_val e = Some v →
    head_step (Unfold (Fold e)) e
(** Casts *)
(* Between same base type *)
| IdBase e v:
    to_val e = Some v →
    head_step (Cast e TUnit TUnit) e
(* Between two times star *)
| IdStar e v:
    to_val e = Some v →
    head_step (Cast e TUnknown TUnknown) e
(* Between two ground types *)
| Same_Ground e v τ :
    to_val e = Some v →
    Ground τ →
    head_step (Cast (Cast e τ TUnknown) TUnknown τ) e
| Different_Ground e v τ1 τ2 (G1 : Ground τ1) (G2 : Ground τ2):
    to_val e = Some v →
    not (τ1 = τ2) →
    head_step (Cast (Cast e τ1 TUnknown) TUnknown τ2) CastError
(* Application of function that is casted between arrow types *)
| AppCast e1 v1 e2 v2 τ1 τ2 τ3 τ4:
    to_val e1 = Some v1 →
    to_val e2 = Some v2 →
    head_step
      (App (Cast e1 (TArrow τ1 τ2) (TArrow τ3 τ4)) e2)
      (Cast (App e1 (Cast e2 τ3 τ1)) τ2 τ4)
(* Cast between two product casts *)
| ProdCast e1 v1 e2 v2 τ1 τ2 τ1' τ2':
    to_val e1 = Some v1 →
    to_val e2 = Some v2 →
    head_step
      (Cast (Pair e1 e2) (TProd τ1 τ2) (TProd τ1' τ2'))
      (Pair (Cast e1 τ1 τ1') (Cast e2 τ2 τ2'))
| SumCast1 e1 v1 τ1 τ2 τ1' τ2':
    to_val e1 = Some v1 →
    head_step
      (Cast (InjL e1) (TSum τ1 τ2) (TSum τ1' τ2'))
      (InjL (Cast e1 τ1 τ1'))
| SumCast2 e2 v2 τ1 τ2 τ1' τ2':
    to_val e2 = Some v2 →
    head_step
      (Cast (InjR e2) (TSum τ1 τ2) (TSum τ1' τ2'))
      (InjR (Cast e2 τ2 τ2'))
| RecursiveCast e v τb τb':
    to_val e = Some v →
    head_step
      (Cast (Fold e) (TRec τb) (TRec τb'))
      (Fold (Cast e (τb.[TRec τb/]) (τb'.[TRec τb'/])))
(* Factorisations *)
| UpFactorization e v τ τG (G : get_shape τ = Some τG):
    to_val e = Some v →
    ((Ground τ) -> False) →
    (¬ (τ = TUnknown)) →
    head_step
      (Cast e τ TUnknown)
      (Cast (Cast e τ τG) τG TUnknown)
| DownFactorization e v τ τG (G : get_shape τ = Some τG):
    to_val e = Some v →
    (notT (Ground τ)) →
    (¬ (τ = TUnknown)) →
    head_step
      (Cast e TUnknown τ)
      (Cast (Cast e TUnknown τG) τG τ).

Lemma to_of_val v : to_val (of_val v) = Some v.
Proof.
  induction v; simplify_option_eq; try done.
  (* extra case *)
  destruct (ICP_dec τi τf).
  - rewrite IHv. simpl. by rewrite (Unique_ICP_proof τi τf Ip i).
  - (* impossible case *) exfalso. apply n. apply Ip.
Qed.

Lemma of_to_val e v : to_val e = Some v → of_val v = e.
Proof.
  revert v; induction e; intros; simplify_option_eq; auto with f_equal.
  destruct (ICP_dec τi τf).
  - destruct (to_val e); simplify_option_eq; by rewrite IHe.
  - inversion H.
Qed.

Lemma val_head_stuck e1 e2 :
  head_step e1 e2 → to_val e1 = None.
Proof.
  destruct 1; try naive_solver.
  - simpl.
    destruct (ICP_dec TUnknown τ).
    destruct (Ground_dec τ); simplify_option_eq.
    inversion i. inversion G. done. done.
  - simpl.
    destruct (ICP_dec TUnknown τ2).
    destruct (Ground_dec τ1); simplify_option_eq.
    inversion i. inversion G. auto.
  - simpl.
    by destruct (Ground_dec τ); simplify_option_eq.
  - simpl.
    destruct (ICP_dec τ TUnknown).
    inversion i; by exfalso.
    destruct (ICP_dec TUnknown τ).
    inversion i. by exfalso.
    done.
Qed.

Instance of_val_inj : Inj (=) (=) of_val.
Proof. by intros ?? Hv; apply (inj Some); rewrite -!to_of_val Hv. Qed.

Lemma fill_item_val Ki e :
  is_Some (to_val (fill_item Ki e)) → is_Some (to_val e).
Proof. intros [v ?]. destruct Ki; simplify_option_eq; eauto.
destruct (ICP_dec τi τf).
  simplify_option_eq. by eexists. inversion H.
Qed.

Instance fill_item_inj Ki : Inj (=) (=) (fill_item Ki).
Proof. destruct Ki; intros ???; simplify_eq; auto with f_equal. Qed.

Lemma head_ctx_step_val Ki e e2 :
  head_step (fill_item Ki e) e2 → is_Some (to_val e).
Proof.
  destruct Ki; inversion_clear 1; simplify_option_eq; eauto.
  - simpl.
    destruct (Ground_dec τf); simplify_option_eq.
    by eexists.
    by exfalso.
  - destruct (Ground_dec τ1); simplify_option_eq.
    by eexists.
Qed.

Lemma fill_item_no_val_inj Ki1 Ki2 e1 e2 :
  to_val e1 = None → to_val e2 = None →
  fill_item Ki1 e1 = fill_item Ki2 e2 → Ki1 = Ki2.
Proof.
  destruct Ki1, Ki2; intros; try discriminate; simplify_eq;
  repeat match goal with
          | H : to_val (of_val _) = None |- _ => by rewrite to_of_val in H
          end; auto.
Qed.

(** General evaluation contexts *)
Notation ectx := (list ectx_item).

Definition fill (K : ectx) (e : expr) : expr := foldl (flip fill_item) e K.

Instance fill_inj K : Inj (=) (=) (fill K).
Proof.
  induction K as [| Ki K IH]; rewrite /Inj; naive_solver.
Qed.

Notation observation := Empty_set.

(** Reduction relation of our language *)
Inductive prim_step : expr → list observation → expr → list expr → Prop :=
  | Ectx_step K e1 e1' e2 e2' :
    e1 = fill K e1' → e2 = fill K e2' →
    head_step e1' e2' → prim_step e1 [] e2 []
  | CastError_step K (ne : K ≠ []) :
    prim_step (fill K CastError) [] CastError [].

Lemma fill_item_not_val Ki e : to_val e = None → to_val (fill_item Ki e) = None.
Proof.
  destruct Ki; intro; simplify_option_eq; try done.
  rewrite to_of_val /= H; by simpl.
  by destruct ICP_dec; try done; rewrite H /=.
Qed.

Lemma fill_not_val K e : to_val e = None → to_val (fill K e) = None.
Proof.
  generalize dependent e.
  induction K. by simpl. intros. simpl. rewrite IHK; auto. by rewrite fill_item_not_val.
Qed.

Lemma val_prim_stuck e1 ks e2 ls : prim_step e1 ks e2 ls → to_val e1 = None.
Proof.
  destruct 1.
  - simplify_eq. apply fill_not_val.
    by eapply val_head_stuck.
  - apply fill_not_val. by simpl.
Qed.

Lemma lang_mixin : @LanguageMixin _ _ () Empty_set of_val to_val (fun e1 _ ls e2 _ ks => prim_step e1 ls e2 ks).
Proof.
  split; apply _ || intros; eauto using to_of_val, of_to_val, val_prim_stuck.
Qed.

Canonical Structure stateO := leibnizO state.
Canonical Structure valO := leibnizO val.
Canonical Structure exprO := leibnizO expr.

(** Defines language using the Iris `Language` structure *)
Canonical Structure lang : language := Language lang_mixin.

Hint Extern 20 (PureExec _ _ _) => progress simpl : typeclass_instances.

Hint Extern 5 (IntoVal _ _) => eapply of_to_val; fast_done : typeclass_instances.
Hint Extern 10 (IntoVal _ _) =>
  rewrite /IntoVal; eapply of_to_val; rewrite /= !to_of_val /=; solve [ eauto ] : typeclass_instances.

Hint Extern 5 (AsVal _) => eexists; eapply of_to_val; fast_done : typeclass_instances.
Hint Extern 10 (AsVal _) =>
  eexists; rewrite /IntoVal; eapply of_to_val; rewrite /= !to_of_val /=; solve [ eauto ] : typeclass_instances.

(** Definition of halting *)
Definition Halts (e : expr) :=
  ∃ v, rtc erased_step ([e], tt) ([of_val v], tt).


(** * Extraction: Extracting OCaml from Coq *)

(* ################################################################# *)
(** * Basic Extraction *)

(** In its simplest form, extracting an efficient program from one
    written in Coq is completely straightforward.

    First we say what language we want to extract into.  Options are
    OCaml (the most mature), Haskell (mostly works), and Scheme (a bit
    out of date). *)

Require Coq.extraction.Extraction.
Extraction Language OCaml.

(** Now we load up the Coq environment with some definitions, either
    directly or by importing them from other modules. *)

From Coq Require Import Arith.Arith.
From Coq Require Import Init.Nat.
From Coq Require Import Arith.EqNat.
From LF Require Import ImpCEvalFun.

(** Finally, we tell Coq the name of a definition to extract and the
    name of a file to put the extracted code into. *)

Extraction "imp1.ml" ceval_step.

(** When Coq processes this command, it generates a file [imp1.ml]
    containing an extracted version of [ceval_step], together with
    everything that it recursively depends on.  Compile the present
    [.v] file and have a look at [imp1.ml] now. *)

(* ################################################################# *)
(** * Controlling Extraction of Specific Types *)

(** We can tell Coq to extract certain [Inductive] definitions to
    specific OCaml types.  For each one, we must say
      - how the Coq type itself should be represented in OCaml, and
      - how each constructor should be translated. *)

Extract Inductive bool => "bool" [ "true" "false" ].

(** Also, for non-enumeration types (where the constructors take
    arguments), we give an OCaml expression that can be used as a
    "recursor" over elements of the type.  (Think Church numerals.) *)

Extract Inductive nat => "int"
  [ "0" "(fun x -> x + 1)" ]
  "(fun zero succ n ->
      if n=0 then zero () else succ (n-1))".

(** We can also extract defined constants to specific OCaml terms or
    operators. *)

Extract Constant plus => "( + )".
Extract Constant mult => "( * )".
Extract Constant eqb => "( = )".

(** Important: It is entirely _your responsibility_ to make sure that
    the translations you're proving make sense.  For example, it might
    be tempting to include this one

      Extract Constant minus => "( - )".

    but doing so could lead to serious confusion!  (Why?)
*)

Extraction "imp2.ml" ceval_step.

(** Have a look at the file [imp2.ml].  Notice how the fundamental
    definitions have changed from [imp1.ml]. *)

(* ################################################################# *)
(** * A Complete Example *)

(** To use our extracted evaluator to run Imp programs, all we need to
    add is a tiny driver program that calls the evaluator and prints
    out the result.

    For simplicity, we'll print results by dumping out the first four
    memory locations in the final state.

    Also, to make it easier to type in examples, let's extract a
    parser from the [ImpParser] Coq module.  To do this, we first need
    to set up the right correspondence between Coq strings and lists
    of OCaml characters. *)

Require Import ExtrOcamlBasic.
Require Import ExtrOcamlString.

(** We also need one more variant of booleans. *)

Extract Inductive sumbool => "bool" ["true" "false"].

(** The extraction is the same as always. *)

From LF Require Import Imp.
From LF Require Import ImpParser.

From LF Require Import Maps.
Extraction "imp.ml" empty_st ceval_step parse.

(** Now let's run our generated Imp evaluator.  First, have a look at
    [impdriver.ml].  (This was written by hand, not extracted.)

    Next, compile the driver together with the extracted code and
    execute it, as follows.

        ocamlc -w -20 -w -26 -o impdriver imp.mli imp.ml impdriver.ml
        ./impdriver

    (The [-w] flags to [ocamlc] are just there to suppress a few
    spurious warnings.) *)

(* ################################################################# *)
(** * Discussion *)

(** Since we've proved that the [ceval_step] function behaves the same
    as the [ceval] relation in an appropriate sense, the extracted
    program can be viewed as a _certified_ Imp interpreter.  Of
    course, the parser we're using is not certified, since we didn't
    prove anything about it! *)

(* ################################################################# *)
(** * Going Further *)

(** Further details about extraction can be found in the Extract
    chapter in _Verified Functional Algorithms_ (_Software
    Foundations_ volume 3). *)

(* 2022-08-08 17:13 *)


Require Export Coq.Strings.String
        Coq.ZArith.ZArith
        Coq.Lists.List
        Coq.Logic.FunctionalExtensionality
        Coq.Sets.Ensembles
        Fiat.Common.Ensembles.IndexedEnsembles
        Fiat.Computation
        Fiat.ADT
        Fiat.ADTRefinement
        Fiat.ADTNotation
        Fiat.ADTRefinement.BuildADTRefinements
        Fiat.QueryStructure.Specification.Representation.Notations
        Fiat.QueryStructure.Specification.Representation.QueryStructureSchema
        Fiat.QueryStructure.Specification.Representation.QueryStructure
        Fiat.QueryStructure.Specification.Operations.Query
        Fiat.QueryStructure.Specification.Operations.Insert
        Fiat.QueryStructure.Specification.Operations.Empty
        Fiat.QueryStructure.Specification.Operations.Update
        Fiat.QueryStructure.Specification.Operations.Delete.

Notation "heading / attr_index" := ((fun x : Attributes heading => x)
                                       {| bindex := attr_index; indexb := _ |})
                                      (at level 40, left associativity) : QueryStructure_scope.

Notation TupleDef sch Ridx :=
  (@RawTuple (GetNRelSchemaHeading (qschemaSchemas sch%QSSchema)
                                  (ibound (indexb (@Build_BoundedIndex _ _ (QSschemaNames sch%QSSchema) Ridx _))))).

Notation "QSSchema # rel_key" := (TupleDef QSSchema rel_key) (at level 100, no associativity) : QueryStructure_scope.

Notation "?[ A ]" := (if A then true else false) (at level 50) : QueryStructure_scope.

Open Scope QSSchema_scope.
Open Scope ADTSig_scope.
Open Scope QueryImpl_scope.
Open Scope QueryStructure_scope.
Open Scope Schema_scope.
Open Scope QuerySpec_scope.
Open Scope string_scope.
Open Scope Tuple_scope.
Open Scope comp_scope.

(* Notation Test. *)
(* Let's define some synonyms for strings we'll need,
 * to save on type-checking time.
Definition sBOOKS := "Books".
Definition sAUTHOR := "Authors".
Definition sTITLE := "Title".
Definition sISBN := "ISBN".
Definition sORDERS := "Orders".
Definition sDATE := "Date".

(* Now here's the actual schema, in the usual sense. *)

Definition BookStoreSchema :=
  Query Structure Schema
    [ relation sBOOKS has
              schema <sAUTHOR :: string,
                      sTITLE :: string,
                      sISBN :: nat>
                      where attributes [sTITLE; sAUTHOR] depend on [sISBN];
      relation sORDERS has
              schema <sISBN :: nat,
                      sDATE :: nat> ]
    enforcing [attribute sISBN for sORDERS references sBOOKS].

(* Aliases for the tuples contained in Books and Orders, respectively. *)
Definition Book := BookStoreSchema # sBOOKS.
Definition Order := BookStoreSchema # sORDERS.

(* Our bookstore has two mutators:
   - [PlaceOrder] : Place an order into the 'Orders' table
   - [AddBook] : Add a book to the inventory

   Our bookstore has two observers:
   - [GetTitles] : The titles of books written by a given author
   - [NumOrders] : The number of orders for a given author
 *)

(* So, first let's give the type signatures of the methods. *)
Definition BookStoreSig : ADTSig :=
  ADTsignature {
      Constructor "Init" : unit -> rep,
      Method "PlaceOrder" : rep x Order -> rep x bool,
      Method "DeleteOrder" : rep x nat -> rep x list Order,
      Method "AddBook" : rep x Book -> rep x bool,
      Method "DeleteBook" : rep x nat -> rep x list Book,
      Method "GetTitles" : rep x string -> rep x list string,
      Method "NumOrders" : rep x string -> rep x nat
    }.

(* Now we write what the methods should actually do. *)

Definition BookStoreSpec : ADT BookStoreSig.

  refine ( QueryADTRep BookStoreSchema {
    Def Constructor "Init" (_ : unit) : rep := empty,

    update "PlaceOrder" ( r : rep , o : Order ) : bool :=
        Insert o into r!sORDERS,

    update "DeleteOrder" (r : rep, oid : nat ) : list Order :=
       Delete o from r!sORDERS where True,

    update "AddBook" (r : rep, b : Book ) : bool :=
        Insert b into r!sBOOKS ,

     update "DeleteBook" ( r : rep, id : nat ) : list Book :=
        Delete book from r!sBOOKS where book!sISBN = id,

    query "GetTitles" (r : rep, author : string ) : list string :=
      For (b in r ! sBOOKS)
      Where (author = b!sAUTHOR)
      Return (b!sTITLE),

    query "NumOrders" (r : rep, author : string ) : nat :=
      Count (For (o in r!sORDERS) (b in r!sBOOKS)
                 Where (author = b!sAUTHOR)
                 Where (o!sISBN = b!sISBN)
                 Return ())
} ).
  (* match goal with
    |- ?A =>
    match type of (Delete o from sORDERS where True : A) with
    | Comp (prod ?A' ?B') => idtac
    end
  end *).
*)


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj28eqsynthconj1 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (mult lv0 lv1) (plus Zero (mult lv0 lv1))).
Admitted.
QuickChick conj28eqsynthconj1.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime A B C D X Bprimeprime Bprime Dprime : Universe, ((wd_ C O /\ (wd_ A O /\ (wd_ B O /\ (wd_ D O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ Eprime C /\ (wd_ Bprime O /\ (wd_ X O /\ (wd_ E Bprimeprime /\ (wd_ C Bprime /\ (wd_ B Bprimeprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ O E D /\ (col_ O Eprime Bprimeprime /\ (col_ O Eprime Bprime /\ (col_ O Eprime Dprime /\ col_ O A Bprime)))))))))))))))))))) -> col_ O E Eprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D Aprime Bprime Cprime Dprime X Y P : Universe, ((wd_ X A /\ (wd_ X Aprime /\ (wd_ X C /\ (wd_ X Cprime /\ (wd_ Y B /\ (wd_ Y Bprime /\ (wd_ Y D /\ (wd_ Y Dprime /\ (wd_ A B /\ (wd_ Aprime Bprime /\ (wd_ A C /\ (wd_ B D /\ (wd_ A Aprime /\ (wd_ B C /\ (wd_ Bprime Cprime /\ (wd_ A D /\ (wd_ Aprime Dprime /\ (col_ X A C /\ (col_ X A Aprime /\ (col_ X A Cprime /\ (col_ Y B D /\ (col_ Y B Bprime /\ (col_ Y B Dprime /\ (col_ P X Aprime /\ col_ P Y Bprime)))))))))))))))))))))))) -> col_ P Y B)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Common.Common.
Require Import LogRelIE.PseudoType.
Require Import LogRelIE.LemmasPseudoType.
Require Import LogRelIE.LR.
Require Import LogRelIE.LemmasLR.
Require Import LogRelIE.LemmasIntro.
Require Import StlcIso.SpecSyntax.
Require Import StlcIso.CanForm.
Require Import StlcIso.SpecEvaluation.
Require Import StlcIso.LemmasEvaluation.
Require Import StlcIso.LemmasTyping.
Require Import StlcIso.SpecTyping.
Require Import StlcIso.Size.
Require Import StlcEqui.SpecSyntax.
Require Import StlcEqui.SpecEvaluation.
Require Import StlcEqui.LemmasEvaluation.
Require Import StlcEqui.SpecTyping.
Require Import StlcEqui.Inst.
Require Import UValIE.UVal.

Require Import Lia.
Require Import Min.

Section ValrelInversion.

  Local Ltac crush :=
    repeat
      (cbn in * |-; cbn;
       try assumption;
       crushOfType;
       repeat E.crushTyping;
       repeat I.crushTyping;
       repeat E.crushStlcSyntaxMatchH;
       repeat I.crushStlcSyntaxMatchH;
       (* repeat crushUtlcScopingMatchH; *)
       repeat crushDbSyntaxMatchH;
       repeat crushValidPTyMatch;
       try subst;
       destruct_conjs;
       repeat match goal with
                  [ |- _ ∧ _ ] => split
              end;
       repeat match goal with
           [ H : is_inl (I.inl _) _ |- _] => inversion H; clear H
         end;
       eauto
      );
    try discriminate;
    eauto with eval;
    try lia.

  Lemma valrel_ptunit_inversion {d w vs vu} :
    valrel d w ptunit vs vu →
    vs = I.unit ∧ vu = E.unit.
  Proof.
    rewrite valrel_fixp; unfold valrel'.
    now intros (? & (? & -> & ?)).
  Qed.

  Lemma valrel_ptbool_inversion {d w vs vu} :
    valrel d w ptbool vs vu →
    (vs = I.true ∧ vu = E.true) ∨ (vs = I.false ∧ vu = E.false).
  Proof.
    rewrite valrel_fixp; unfold valrel'.
    now intros (? & ? & -> & ?).
  Qed.

  Lemma valrel_ptprod_inversion {d w τ₁ τ₂ vs vu} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    valrel d w (ptprod τ₁ τ₂) vs vu →
    exists vs₁ vs₂ vu₁ vu₂,
      (vs = I.pair vs₁ vs₂ ∧ vu = E.pair vu₁ vu₂ ∧
       OfType τ₁ vs₁ vu₁ ∧
       OfType τ₂ vs₂ vu₂ ∧
       ∀ w', w' < w → valrel d w' τ₁ vs₁ vu₁ ∧ valrel d w' τ₂ vs₂ vu₂).
  Proof.
    intros vτ₁ vτ₂ vr.
    destruct (OfType_inversion_ptprod vτ₁ vτ₂ (valrel_implies_OfType vr))
      as (ts1' & tu1' & ts2' & tu2' & Hvs & Hvu & oft1 & oft2).
    exists ts1', ts2', tu1', tu2';
    rewrite -> valrel_fixp in vr;
    unfold valrel' in vr; crush.
  Qed.

  Lemma valrel_ptsum_inversion {d w τ₁ τ₂ vs vu} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    valrel d w (ptsum τ₁ τ₂) vs vu →
    exists vs' vu',
      (vs = I.inl vs' ∧ vu = E.inl vu' ∧
       OfType τ₁ vs' vu' ∧
       ∀ w', w' < w → valrel d w' τ₁ vs' vu') ∨
      (vs = I.inr vs' ∧ vu = E.inr vu' ∧
       OfType τ₂ vs' vu' ∧
       ∀ w', w' < w → valrel d w' τ₂ vs' vu').
  Proof.
    intros vτ₁ vτ₂ vr.
    rewrite -> valrel_fixp in vr; destruct vr as [oft sumrel];
    apply OfType_inversion_ptsum in oft;
    destruct oft as (tsb & tub & Hvs); intuition; crush;
    exists tsb, tub; crush.
  Qed.

  Lemma valrel_ptarr_inversion {d w τ₁ τ₂ vs vu} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    valrel d w (ptarr τ₁ τ₂) vs vu →
    ∃ tsb tub τ₁',
      vs = I.abs (repEmul τ₁) tsb ∧ vu = E.abs τ₁' tub ∧
        ValidTy τ₁' /\
        ⟪ τ₁' ≗ isToEq τ₁ ⟫ /\
      ⟪ empty r▻ repEmul τ₁ i⊢ tsb : repEmul τ₂ ⟫ ∧
      ⟪ empty r▻ isToEq τ₁ e⊢ tub : isToEq τ₂ ⟫ ∧
      ∀ w' vs' vu',
        w' < w →
        (d = dir_gt -> E.size vu' <= w') ->
        valrel d w' τ₁ vs' vu' →
        termrel d w' τ₂ (tsb[beta1 vs']) (tub[beta1 vu']).
  Proof.
    intros vτ₁ vτ₂ vr.
    destruct (valrel_implies_Value vr) as [? ?].
    destruct (OfType_inversion_ptarr vτ₁ vτ₂ (valrel_implies_OfType vr))
      as (tsb & tub & ? & ? & ?).
    exists tsb, tub, x. crush.
    rewrite -> valrel_fixp in vr.
    unfold valrel' in vr; unfold termrel; crush.
  Qed.

  Lemma invert_valrel_pEmulDV_zero {dir w p vs vu τ} :
    ValidTy τ ->
    valrel dir w (pEmulDV 0 p τ) vs vu →
    OfType (pEmulDV 0 p τ) vs vu ∧ vs = I.unit ∧ p = imprecise.
  Proof.
    rewrite valrel_fixp.
    intros vτ (? & ? & <- & ? & vr).
    now cbn in vr.
  Qed.

  Lemma invert_valrel_pEmulDV_unk {dir w n p vu τ} :
    valrel dir w (pEmulDV (S n) p τ) (I.inr I.unit) vu →
    p = imprecise.
  Proof.
    intros vr.
    rewrite valrel_fixp in vr; unfold valrel' in vr.
    destruct vr as (ot & (? & <- & ? & [(? & ?) | ?])).
    - assumption.
    - destruct (unfoldn (LMC τ) τ); destruct_conjs; unfold is_inl in H0; crush.
  Qed.

  Lemma invert_valrel_pEmulDV_inUnit' {dir w n p vs vu} :
    valrel dir w (pEmulDV (S n) p E.tunit) (I.inl vs) vu →
    vs = I.unit ∧ vu = E.unit.
  Proof.
    intros vr.
    rewrite valrel_fixp in vr.
    unfold valrel' in vr.
    destruct vr as (ot & (? & <- & ? & [(? & ?) | ?]));
      try (destruct H as [? H']; unfold is_inl in H');
      crush.
  Qed.

  Lemma invert_valrel_pEmulDV_inUnit {dir w n p vs vu} :
    valrel dir w (pEmulDV (S n) p E.tunit) (I.inl vs) vu →
    valrel dir w ptunit vs vu.
  Proof.
    intros vr.
    destruct (invert_valrel_pEmulDV_inUnit' vr); subst.
    apply valrel_unit.
  Qed.

  Lemma invert_valrel_pEmulDV_unit {dir w n p vs vu} :
   valrel dir w (pEmulDV (S n) p E.tunit) vs vu →
    (vs = unkUVal (S n) ∧ p = imprecise) ∨
    ∃ vs', (vs = I.inl vs' ∧ valrel dir w ptunit vs' vu).
  Proof.
    intro vr.
    destruct (valrel_implies_OfType vr) as [[? ?] [? ?]].
    cbn in *; unfold UValIE in H0; cbn in *.
    E.stlcCanForm.
    I.stlcCanForm.
    - right. eexists; eauto using invert_valrel_pEmulDV_inUnit.
    - eauto using invert_valrel_pEmulDV_unk.
  Qed.

  (* TODO: ^^ one of these per type **)

  Lemma invert_valrel_pEmulDV_inVar {dir w n p vs vu i} :
    not (valrel dir w (pEmulDV (S n) p (E.tvar i)) (I.inl vs) vu).
  Proof.
    intros vr.
    rewrite valrel_fixp in vr; unfold valrel' in vr.
    destruct vr as (? & ? & <- & ? & [[? ?] | ?]);
    crush.
  Qed.

  Lemma invert_valrel_pEmulDV_var {dir w n p vs vu i} :
    valrel dir w (pEmulDV (S n) p (E.tvar i)) vs vu →
    vs = unkUVal (S n) ∧ p = imprecise.
  Proof.
    intro vr.
    destruct (valrel_implies_OfType vr) as [[? ?] [? ?]].
    cbv in H0, H2.
    E.stlcCanForm.
    I.stlcCanForm.
    - exfalso. exact (invert_valrel_pEmulDV_inVar vr).
    - eauto using invert_valrel_pEmulDV_unk.
  Qed.

  Lemma invert_valrel_pEmulDV_inBool' {dir w n p vs vu} :
    valrel dir w (pEmulDV (S n) p tbool) (inBool n vs) vu →
    (vs = I.true ∧ vu = E.true) ∨ (vs = I.false ∧ vu = E.false).
  Proof.
    intros vr.
    rewrite valrel_fixp in vr; unfold valrel' in vr.
    destruct vr as (_ & ? & <- & ? & [(? & ?)|(? & ? & [(? & ?)|(? & ?)])]);
      unfold is_inl in *;
      crush.
  Qed.

  Lemma invert_valrel_pEmulDV_inBool {dir w n p vs vu} :
    valrel dir w (pEmulDV (S n) p tbool) (inBool n vs) vu →
    valrel dir w ptbool vs vu.
  Proof.
    intros vr.
    destruct (invert_valrel_pEmulDV_inBool' vr) as [[? ?]|[? ?]]; subst;
    auto using valrel_true, valrel_false.
  Qed.

  Lemma invert_valrel_pEmulDV_bool {dir w n p vs vu} :
   valrel dir w (pEmulDV (S n) p E.tbool) vs vu →
    (vs = unkUVal (S n) ∧ p = imprecise) ∨
    ∃ vs', (vs = I.inl vs' ∧ valrel dir w ptbool vs' vu).
  Proof.
    intro vr.
    destruct (valrel_implies_OfType vr) as [[? ?] [? ?]].
    cbn in *; unfold UValIE in H0; cbn in *.
    rewrite valrel_fixp in vr; unfold valrel' in vr; cbn in vr.
    destruct vr as (ot & ? & <- & ? & [(-> & ->)|(ts' & eq & vr)]).
    - left. eauto using invert_valrel_pEmulDV_unk.
    - right.
      exists ts'.
      split; [exact eq|].
      destruct vr as [[? ?]|[? ?]]; subst; eauto using valrel_true, valrel_false.
  Qed.

  Lemma invert_valrel_pEmulDV_inProd' {dir w n p τ₁ τ₂ vs vu} :
    ValidTy τ₁ -> ValidTy τ₂ ->
    valrel dir w (pEmulDV (S n) p (E.tprod τ₁ τ₂)) (inProd n vs) vu →
    ∃ vs₁ vs₂ vu₁ vu₂, vs = I.pair vs₁ vs₂ ∧ vu = E.pair vu₁ vu₂ ∧
                       (∀ w', w' < w → valrel dir w' (pEmulDV n p τ₁) vs₁ vu₁) ∧
                       (∀ w', w' < w → valrel dir w' (pEmulDV n p τ₂) vs₂ vu₂).
  Proof.
    intros vτ₁ vτ₂ vr.
    rewrite valrel_fixp in vr; unfold valrel' in vr.
    assert (ValidEnv empty) by crush.
    destruct vr as ([[vvs tvs] [vvu tvu]] & ? & <- & ? & [(? & ?) |(x & ? & vr)]);
      unfold is_inl in *; simpl in *; crush.
    I.stlcCanForm.
    E.stlcCanForm.
    exists x0, x1, x, x2; crush.
  Qed.

  Lemma invert_valrel_pEmulDV_inProd {dir w n p τ₁ τ₂ vs vu} :
    ValidTy τ₁ -> ValidTy τ₂ ->
    valrel dir w (pEmulDV (S n) p (E.tprod τ₁ τ₂)) (inProd n vs) vu →
    valrel dir w (ptprod (pEmulDV n p τ₁) (pEmulDV n p τ₂)) vs vu.
  Proof.
    intros vτ₁ vτ₂ vr.
    destruct (valrel_implies_OfType vr) as [[? ?] [? ?]].
    destruct (invert_valrel_pEmulDV_inProd' vτ₁ vτ₂ vr) as (? & ? & ? & ? & ? & ? & ? & ?); subst.
    assert (ValidEnv empty) by crush.
    apply valrel_pair''; crush;
      now E.try_typed_terms_are_valid.
  Qed.

  Lemma invert_valrel_pEmulDV_prod {dir w n p vs vu τ₁ τ₂} :
    ValidTy τ₁ -> ValidTy τ₂ ->
    valrel dir w (pEmulDV (S n) p (E.tprod τ₁ τ₂)) vs vu →
    (vs = unkUVal (S n) ∧ p = imprecise)
    ∨ exists vs', vs = I.inl vs' ∧ valrel dir w (ptprod (pEmulDV n p τ₁) (pEmulDV n p τ₂)) vs' vu.
  Proof.
    intros vτ₁ vτ₂ vr.
    destruct (valrel_implies_OfType vr) as [[? ?] [? ?]].
    cbv [UValIE UValIE' isToEq repEmul] in *.
    I.stlcCanForm; [right | eauto using invert_valrel_pEmulDV_unk].
    exists (I.pair x0 x1).
    crush; exact (invert_valrel_pEmulDV_inProd vτ₁ vτ₂ vr).
  Qed.

  Lemma invert_valrel_pEmulDV_inSum' {dir w n p vs vu τ₁ τ₂} :
    ValidTy τ₁ -> ValidTy τ₂ ->
    valrel dir w (pEmulDV (S n) p (E.tsum τ₁ τ₂)) (I.inl vs) vu →
    ∃ vs' vu', ((vs = I.inl vs' ∧ vu = E.inl vu') ∨ (vs = I.inr vs' ∧ vu = E.inr vu')) ∧
               ((∀ w', w' < w → valrel dir w' (pEmulDV n p τ₁) vs' vu')
                ∨ (∀ w', w' < w → valrel dir w' (pEmulDV n p τ₂) vs' vu')).
  Proof.
    intros vτ₁ vτ₂ vr.
    rewrite valrel_fixp in vr; unfold valrel' in vr.
    destruct vr as (? & ? & <- & ? & [? | [? ?]]); crush.
    unfold OfType, OfTypeStlcIso, OfTypeStlcEqui in H; destruct_conjs.
    unfold is_inl in H0.
    assert (I.Value (I.inl x)) by crush.
    unfold sum_rel in H1; simpl in H1.
    destruct x; destruct vu;
    try exists x, vu; crush.
  Qed.

  Lemma invert_valrel_pEmulDV_inSum'' {dir w n p vs vu τ₁ τ₂} :
    ValidTy τ₁ -> ValidTy τ₂ ->
    valrel dir w (pEmulDV (S n) p (E.tsum τ₁ τ₂)) (I.inl vs) vu →
    ∃ vs' vu',
        ((vs = I.inl vs' ∧ vu = E.inl vu' ∧ (∀ w', w' < w → valrel dir w' (pEmulDV n p τ₁) vs' vu'))
        ∨ (vs = I.inr vs' ∧ vu = E.inr vu' ∧
               (∀ w', w' < w → valrel dir w' (pEmulDV n p τ₂) vs' vu'))).
  Proof.
    intros vτ₁ vτ₂ vr.
    rewrite valrel_fixp in vr; unfold valrel' in vr.
    destruct vr as (? & ? & <- & ? & [? | [? ?]]); crush.
    unfold OfType, OfTypeStlcIso, OfTypeStlcEqui in H; destruct_conjs.
    unfold is_inl in H0.
    assert (I.Value (I.inl x)) by crush.
    unfold sum_rel in H1; simpl in H1.
    destruct x; destruct vu;
    try exists x, vu; crush.
  Qed.

  Lemma invert_valrel_pEmulDV_inSum {dir w n p vs vu τ₁ τ₂} :
    ValidTy τ₁ -> ValidTy τ₂ ->
    valrel dir w (pEmulDV (S n) p (E.tsum τ₁ τ₂)) (I.inl vs) vu →
    valrel dir w (ptsum (pEmulDV n p τ₁) (pEmulDV n p τ₂)) vs vu.
  Proof.
    intros vτ₁ vτ₂ vr.
    assert (ValidEnv empty) by crush.
    destruct (valrel_implies_OfType vr) as [[? ?] [? ?]].
    destruct (invert_valrel_pEmulDV_inSum'' vτ₁ vτ₂ vr) as (? & ? & [(? & ? & ?) | (? & ? & ?)]);
      subst;
      [apply valrel_inl''| apply valrel_inr''];
      crush; now E.try_typed_terms_are_valid.
  Qed.

  Lemma invert_valrel_pEmulDV_sum {dir w n p vs vu τ₁ τ₂} :
    ValidTy τ₁ -> ValidTy τ₂ ->
    valrel dir w (pEmulDV (S n) p (E.tsum τ₁ τ₂)) vs vu →
    (vs = unkUVal (S n) ∧ p = imprecise)
    ∨ exists vs', vs = I.inl vs' ∧ valrel dir w (ptsum (pEmulDV n p τ₁) (pEmulDV n p τ₂)) vs' vu.
  Proof.
    intros vτ₁ vτ₂ vr.
    destruct (valrel_implies_OfType vr) as [[? ?] [? ?]].
    cbv [UValIE UValIE' isToEq repEmul] in *.
    I.stlcCanForm; [right | right | eauto using invert_valrel_pEmulDV_unk];
    [exists (I.inl x0) | exists (I.inr x0)];
    crush; exact (invert_valrel_pEmulDV_inSum vτ₁ vτ₂ vr).
  Qed.

  Lemma invert_valrel_pEmulDV_inArr {dir w n p vs vu τ₁ τ₂} :
    ValidTy τ₁ -> ValidTy τ₂ ->
    valrel dir w (pEmulDV (S n) p (E.tarr τ₁ τ₂)) (I.inl vs) vu →
    valrel dir w (ptarr (pEmulDV n p τ₁) (pEmulDV n p τ₂)) vs vu.
  Proof.
    assert (ValidEnv empty) by crush.
    rewrite valrel_fixp; unfold valrel'.
    intros vτ₁ vτ₂ vr.
    split.
    destruct vr as (? & ? & <- & ? & [? | [? ?]]);
    unfold OfType, OfTypeStlcIso, OfTypeStlcEqui in *; destruct_conjs;
    crush.
    destruct vr as (? & ? & <- & ? & [? | [? [? ?]]]).
      - crush.
      - inversion H2; subst.
        crush.
  Qed.

  Lemma invert_valrel_pEmulDV_arr {dir w n p vs vu τ₁ τ₂} :
    ValidTy τ₁ -> ValidTy τ₂ ->
    valrel dir w (pEmulDV (S n) p (E.tarr τ₁ τ₂)) vs vu →
    (vs = unkUVal (S n) ∧ p = imprecise) ∨
    exists vs', vs = I.inl vs' ∧ valrel dir w (ptarr (pEmulDV n p τ₁) (pEmulDV n p τ₂)) vs' vu.
  Proof.
    intros vτ₁ vτ₂ vr.
    destruct (valrel_implies_OfType vr) as [[? ?] [? ?]].
    cbv [UValIE UValIE' isToEq repEmul] in *.
    I.stlcCanForm.
    - right. exists x. crush. exact (invert_valrel_pEmulDV_inArr vτ₁ vτ₂ vr).
    - eauto using invert_valrel_pEmulDV_unk.
  Qed.

  (* Lemma invert_valrel_pEmulDV_inRec {dir w n p vs vu τ} : *)
  (*   ValidTy τ -> *)
  (*   valrel dir (S w) (pEmulDV (S n) p (E.trec τ)) (I.inl vs) (E.fold_ vu) → *)
  (*   valrel dir w (pEmulDV n p τ[beta1 (E.trec τ)]) vs vu. *)
  (* Proof. *)
  (*   intros vτ vr. *)
  (*   rewrite valrel_fixp in vr; unfold valrel' in vr. *)
  (*   destruct vr as [? [? | [? ?]]]; crush. *)
  (*   unfold OfType, OfTypeStlcFix, OfTypeStlcIso in H; destruct_conjs. *)
  (*   unfold is_inl in H0. *)
  (*   inversion H0. *)
  (*   subst. *)
  (*   assert (I.Value (I.inl x)) by crush. *)
  (*   apply H3. *)
  (*   lia. *)
  (* Qed. *)

  (* Lemma invert_valrel_pEmulDV_rec {dir w n p vs vu τ} : *)
  (*   ValidTy τ -> *)
  (*   valrel dir (S w) (pEmulDV (S n) p (E.trec τ)) vs vu → *)
  (*   (vs = unkUVal (S n) ∧ p = imprecise) ∨ *)
  (*   exists vs' vu', vs = I.inl vs' ∧ vu = E.fold_ vu' ∧ valrel dir w (pEmulDV n p τ[beta1 (E.trec τ)]) vs' vu'. *)
  (* Proof. *)
  (*   intro vr. *)
  (*   destruct (valrel_implies_OfType vr) as [[? ?] [? ?]]. *)
  (*   cbv [UValIE UValIE' fxToIs repEmul] in *. *)
  (*   destruct (E.can_form_trec H1 H2) as (? & ? & ?). *)
  (*   I.stlcCanForm. *)
  (*   - right. exists x0, x. crush. exact (invert_valrel_pEmulDV_inRec vr). *)
  (*   - eauto using invert_valrel_pEmulDV_unk. *)
  (* Qed. *)

  (* Lemma invert_valrel_pEmulDV {dir w n p vs vu} : *)
  (*   valrel dir w (pEmulDV (S n) p) vs vu → *)
  (*   (vs = unkUVal (S n) ∧ p = imprecise) ∨ *)
  (*   ∃ vs', vs = I.inl vs' *)
  (*     (vs = inUnit n vs' ∧ valrel dir w ptunit vs' vu) ∨ *)
  (*     (vs = inBool n vs' ∧ valrel dir w ptbool vs' vu) ∨ *)
  (*     (vs = inProd n vs' ∧ valrel dir w (ptprod (pEmulDV n p) (pEmulDV n p)) vs' vu) ∨ *)
  (*     (vs = inSum n vs' ∧ valrel dir w (ptsum (pEmulDV n p) (pEmulDV n p)) vs' vu) ∨ *)
  (*     (vs = inArr n vs' ∧ valrel dir w (ptarr (pEmulDV n p) (pEmulDV n p)) vs' vu). *)
  (* Proof. *)
  (*   intros vr. *)
  (*   destruct (valrel_implies_OfType vr) as [[? ?] _]. *)
  (*   simpl in H0. *)
  (*   canonUVal. *)
  (*   - left; crush. *)
  (*     exact (invert_valrel_pEmulDV_unk vr). *)
  (*   - right. exists x. left. crush. *)
  (*     exact (invert_valrel_pEmulDV_inUnit vr). *)
  (*   - right. exists x. right. left. crush. *)
  (*     exact (invert_valrel_pEmulDV_inBool vr). *)
  (*   - right. exists x. right. right. left. crush. *)
  (*     exact (invert_valrel_pEmulDV_inProd vr). *)
  (*   - right. exists x. right. right. right. left. crush. *)
  (*     exact (invert_valrel_pEmulDV_inSum vr). *)
  (*   - right. exists x. right. right. right. right. crush. *)
  (*     exact (invert_valrel_pEmulDV_inArr vr). *)
  (* Qed. *)
End ValrelInversion.

Ltac invert_valrel_pEmulDV :=
  match goal with
      | [ H : valrel _ _ (pEmulDV (S _) _ E.tunit) _ _ |- _ ] =>
      destruct (invert_valrel_pEmulDV_inUnit H)
      | [ H : valrel _ _ (pEmulDV (S _) _ (E.tsum _ _)) _ _ |- _ ] =>
      destruct (invert_valrel_pEmulDV_inSum H)
      | [ H : valrel _ _ (pEmulDV (S _) _ (E.tarr _ _)) _ _ |- _ ] =>
      destruct (invert_valrel_pEmulDV_inArr H)
      (* | [ H : valrel _ _ (pEmulDV (S _) _ (E.trec _)) _ _ |- _ ] => *)
      (* destruct (invert_valrel_pEmulDV_inRec H) *)
      | [ H : valrel _ _ (pEmulDV 0 _ _) _ _ |- _ ] =>
      destruct (invert_valrel_pEmulDV_zero H) as (? & ? & ?)
  end.

(* Lemma valrel_precise_size {w τ vs vu n} : *)
(*   valrel dir_gt w (pEmulDV n precise τ) vs vu -> *)
(*   size vs <= S (S w). *)
(* Proof. *)
(*   revert vs vu n. *)
(*   induction τ; *)
(*     intros vs vu n; *)
(*     rewrite valrel_fixp; *)
(*     unfold valrel'; *)
(*            intros [ot vr]; *)
(*     destruct n. *)
(*   - destruct vr as [-> [=]]. *)
(*   - destruct vr as [[_ eq] _|(ts' & -> & vr)]; try inversion eq. *)
(*     cbn. *)
(*     destruct vr as (tsb & tub & τ₁' & τ₂' & -> & -> & vr). *)
(*     cbn. *)
(*     lia. *)
(*   - destruct vr as (-> & [= ]). *)
(*   - destruct vr as [(_ & [= ])| (? & -> & -> & ->)]. *)
(*     cbn. lia. *)
(*   - destruct vr as (-> & [=]). *)
(*   - destruct vr as [(_ & [= ])| (ts & -> & hyp)]. *)
(*     destruct ts, vu; try contradiction. *)
(*     destruct w. *)
(*     unfold sum_rel in hyp. *)
(*     cbn. *)
(*     eapply IHτ1. *)
(*     rewrite valrel_fixp; unfold valrel'; cbn. *)
(*     split; eauto. *)
(*     cbn; lia. *)
(*   -  *)

Lemma OfType_pEmulDV_unfoldn {n p τ ts tu} :
  ValidTy τ ->
  OfType (pEmulDV n p τ) ts tu <->
  OfType (pEmulDV n p (unfoldn (LMC τ) τ)) ts tu.
Proof.
  intros vτ; split;
    intros ((vvs & tvs) & (vvu & tvu));
  cbn in *;
  repeat split; cbn; try assumption;
  rewrite <-?UValIE_unfoldn in tvs;
  rewrite <-?UValIE_unfoldn;
    try assumption; crushValidTy.
  - refine (WtEq _ _ _ _ tvu);
      eauto using E.ValidTy_unfoldn with tyvalid.
    eapply ty_eq_peel_recs; E.crushValidTy.
    eapply tyeq_refl.
  - refine (WtEq _ _ _ _ tvu);
      eauto using E.ValidTy_unfoldn with tyvalid.
    eapply ty_eq_unf_ty; E.crushValidTy.
    eapply tyeq_refl.
Qed.

Lemma valrel_pEmulDV_unfoldn {d n p w τ ts tu} :
  ValidTy τ ->
  valrel d w (pEmulDV n p τ) ts tu <->
  valrel d w (pEmulDV n p (unfoldn (LMC τ) τ)) ts tu.
Proof.
  intros vτ.
  rewrite valrel_fixp.
  unfold valrel'.
  cbn.
  rewrite unfoldn_LMC; E.crushValidTy.
  cbn.
  now rewrite <-OfType_pEmulDV_unfoldn.
Qed.

Lemma OfType_tyeq {T U n p ts tu} :
  ValidTy T ->
  ValidTy U ->
  ⟪ T ≗ U ⟫ ->
  OfType (pEmulDV n p T) ts tu <->
  OfType (pEmulDV n p U) ts tu.
Proof.
  intros vT vU tyeq; split;
  intros [[vts tts] [vtu ttu]];
  repeat split;
  cbn in *; try assumption.
  - now rewrite <-?(UVal_eq vT vU tyeq).
  - refine (WtEq _ tyeq vT vU ttu).
  - now rewrite ?(UVal_eq vT vU tyeq).
  - refine (WtEq _ (tyeq_symm tyeq) vU vT ttu).
Qed.

Lemma valrel_tyeq {T U d w n p ts tu} :
  ValidTy T ->
  ValidTy U ->
  ⟪ T ≗ U ⟫ ->
  valrel d w (pEmulDV n p T) ts tu ->
  valrel d w (pEmulDV n p U) ts tu.
Proof.
  revert T U d w p ts tu.
  induction n;
  intros T U d w p ts tu vT vU tyeq;
  rewrite valrel_fixp;
    unfold valrel';
    rewrite (OfType_tyeq vT vU tyeq);
    destruct 1 as [ot vr];
    cbn in *; [eauto|].
  split; [assumption|].
  destruct vr as (? & <- & vts & [[-> ->]|[ts' vr']]); eexists; repeat split; try easy; [now left|right].
  exists ts'.
  assert (⟪ unfoldn (LMC T) T ≗ unfoldn (LMC U) U ⟫).
  refine (eq_trans_contr _ _ (eq_trans_contr _ tyeq _));
    E.crushValidTy.
  eapply ty_eq_peel_recs_left; E.crushValidTy; eapply tyeq_refl.
  eapply ty_eq_peel_recs; E.crushValidTy; eapply tyeq_refl.

  assert (ValidTy (unfoldn (LMC T) T)) by eauto using E.ValidTy_unfoldn.
  assert (ValidTy (unfoldn (LMC U) U)) by eauto using E.ValidTy_unfoldn.
  assert (luz : LMC (unfoldn (LMC U) U) = 0) by (eapply unfoldn_LMC; E.crushValidTy).
  destruct H; eauto.
  - split;[now trivial|].
    eapply E.ValidTy_invert_arr in H0, H1.
    destruct vr' as (-> & ts'' & tu' & τ₁' & τ₂' & -> & -> & trb).
    exists ts'', tu', τ₁', τ₂'.
    intuition.
    specialize (trb w' fw vs vu H1 (IHn _ _ _ _ _ _ _ H0 H3 (tyeq_symm H) H6)).
    unfold termrel', contrel' in *.
    intros Cs Cu eCs eCu contrel.
    eapply (trb Cs Cu eCs eCu).
    intros w'' fw' ts' tu'' vr'.
    eapply (contrel w'' fw' ts' tu'').
    eapply (IHn _ _ _ _ _ _ _ H4 H5 H2 vr').
  - intuition.
    eapply E.ValidTy_invert_sum in H0, H1.
    unfold sum_rel in *.
    destruct ts', tu; intuition;
    specialize (H4 w' fw); refine (IHn _ _ _ _ _ _ _  _ _ _ H4);
      assumption.
  - intuition.
    eapply E.ValidTy_invert_prod in H0, H1.
    unfold prod_rel in *.
    destruct ts', tu; intuition;
    specialize (H1 w' fw);
      specialize (H8 w' fw).
    refine (IHn _ _ _ _ _ _ _  _ _ _ H1); assumption.
    refine (IHn _ _ _ _ _ _ _  _ _ _ H8); assumption.
  - contradiction vr'.
  - cbn in luz.  lia.
Qed.

Lemma valrel_tyeq' {T U d w n p ts tu} :
  ValidTy T ->
  ValidTy U ->
  ⟪ T ≗ U ⟫ ->
  valrel d w (pEmulDV n p T) ts tu <->
  valrel d w (pEmulDV n p U) ts tu.
Proof.
  intros vT vU tyeq.
  assert (tyeq' := tyeq_symm tyeq).
  split; intros vr;
  now refine (valrel_tyeq _ _ _ vr).
Qed.

Lemma compat_type_eq {T U Γ n p d m ts tu} :
  ValidTy T ->
  ValidTy U ->
  ⟪ T ≗ U ⟫ ->
  ⟪ Γ ⊩ ts ⟦d,m⟧ tu : pEmulDV n p T ⟫ ->
  ⟪ Γ ⊩ ts ⟦d,m⟧ tu : pEmulDV n p U ⟫.
Proof.
  intros vT vU tyeq [tts [ttu trel]].
  split; [|split]; cbn in *.
  - now rewrite <-(UVal_eq vT vU tyeq).
  - now refine (WtEq _ _ _ _ ttu).
  - revert trel.
    unfold termrel, termrel', contrel, contrel'.
    now setoid_rewrite <-(valrel_tyeq' vT vU tyeq).
Qed.