Set Implicit Arguments.

Require Import LibLN.

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

(* ###################################################################### *)
(** ** Syntax *)

Parameter typ_label: Set.
Parameter mtd_label: Set.

Inductive label: Set :=
| label_typ: typ_label -> label
| label_mtd: mtd_label -> label.

Module labels.
  Parameter M: typ_label.
  Parameter m: mtd_label.
End labels.

Inductive avar: Set :=
  | avar_b: nat -> avar  (* bound var (de Bruijn index) *)
  | avar_f: var -> avar. (* free var ("name"), refers to tenv or venv *)

Inductive pth: Set :=
  | pth_var: avar -> pth.

Inductive typ: Set :=
  | typ_bind: decs -> typ
  | typ_sel: pth -> typ_label -> typ
with dec: Set :=
  | dec_typ : typ_label -> typ -> typ -> dec
  | dec_tyu : typ_label -> typ -> dec
  | dec_mtd : mtd_label -> typ -> typ -> dec
with decs: Set :=
  | decs_nil : decs
  | decs_cons: dec -> decs -> decs.

Inductive trm: Set :=
  | trm_var : avar -> trm
  | trm_new : defs -> trm
  | trm_call: trm -> mtd_label -> trm -> trm
with def: Set :=
  | def_typ: typ_label -> typ -> typ -> def
  | def_tyu: typ_label -> typ -> def
  | def_mtd: mtd_label -> typ -> typ -> trm -> def
with defs: Set :=
  | defs_nil : defs
  | defs_cons: def -> defs -> defs.

Inductive ctyp: Type :=
  | typ_clo: env ctyp -> typ -> ctyp.

Definition ctx := env ctyp.

(* ###################################################################### *)
(** ** Definition list membership *)

Definition label_of_def(d: def): label := match d with
| def_typ M _ _ => label_typ M
| def_tyu M _ => label_typ M
| def_mtd m _ _ _ => label_mtd m
end.

Definition label_of_dec(D: dec): label := match D with
| dec_typ M _ _ => label_typ M
| dec_tyu M _ => label_typ M
| dec_mtd m _ _ => label_mtd m
end.

Inductive defs_hasnt: defs -> label -> Prop :=
| defs_hasnt_nil: forall l,
    defs_hasnt defs_nil l
| defs_hasnt_cons: forall d ds l,
    defs_hasnt ds l ->
    label_of_def d <> l ->
    defs_hasnt (defs_cons d ds) l.

Inductive defs_has: defs -> def -> Prop :=
| defs_has_hit: forall d ds,
    defs_hasnt ds (label_of_def d) ->
    defs_has (defs_cons d ds) d
| defs_has_skip: forall d1 d2 ds,
    defs_has ds d1 ->
    label_of_def d2 <> label_of_def d1 ->
    defs_has (defs_cons d2 ds) d1.

Inductive decs_hasnt: decs -> label -> Prop :=
| decs_hasnt_nil: forall l,
    decs_hasnt decs_nil l
| decs_hasnt_cons: forall D Ds l,
    decs_hasnt Ds l ->
    label_of_dec D <> l ->
    decs_hasnt (decs_cons D Ds) l.

Inductive decs_has: decs -> dec -> Prop :=
| decs_has_hit: forall D Ds,
    decs_hasnt Ds (label_of_dec D) ->
    decs_has (decs_cons D Ds) D
| decs_has_skip: forall D1 D2 Ds,
    decs_has Ds D1 ->
    label_of_dec D2 <> label_of_dec D1 ->
    decs_has (decs_cons D2 Ds) D1.

(* ###################################################################### *)
(** ** Opening *)

(** Opening replaces in some syntax a bound variable with dangling index (k)
   by a free variable x. *)

Definition open_rec_avar (k: nat) (u: var) (a: avar): avar :=
  match a with
  | avar_b i => If k = i then avar_f u else avar_b i
  | avar_f x => avar_f x
  end.

Definition open_rec_pth (k: nat) (u: var) (p: pth): pth :=
  match p with
  | pth_var a => pth_var (open_rec_avar k u a)
  end.

Fixpoint open_rec_typ (k: nat) (u: var) (T: typ) { struct T }: typ :=
  match T with
  | typ_bind Ds => typ_bind (open_rec_decs (S k) u Ds)
  | typ_sel p M => typ_sel (open_rec_pth k u p) M
  end
with open_rec_dec (k: nat) (u: var) (D: dec) { struct D }: dec :=
  match D with
  | dec_typ M T U => dec_typ M (open_rec_typ k u T) (open_rec_typ k u U)
  | dec_tyu M U => dec_tyu M (open_rec_typ k u U)
  | dec_mtd m T U => dec_mtd m (open_rec_typ k u T) (open_rec_typ k u U)
  end
with open_rec_decs (k: nat) (u: var) (Ds: decs) { struct Ds }: decs :=
  match Ds with
  | decs_nil        => decs_nil
  | decs_cons D Ds' => decs_cons (open_rec_dec k u D) (open_rec_decs k u Ds')
  end.

Fixpoint open_rec_trm (k: nat) (u: var) (t: trm) { struct t }: trm :=
  match t with
  | trm_var a      => trm_var (open_rec_avar k u a)
  | trm_new ds     => trm_new (open_rec_defs (S k) u ds)
  | trm_call o m a => trm_call (open_rec_trm k u o) m (open_rec_trm k u a)
  end
with open_rec_def (k: nat) (u: var) (d: def) { struct d }: def :=
  match d with
  | def_typ M T U => def_typ M (open_rec_typ k u T) (open_rec_typ k u U)
  | def_tyu M U => def_tyu M (open_rec_typ k u U)
  | def_mtd m T U e => def_mtd m (open_rec_typ k u T) (open_rec_typ k u U) (open_rec_trm (S k) u e)
  end
with open_rec_defs (k: nat) (u: var) (ds: defs) { struct ds }: defs :=
  match ds with
  | defs_nil => defs_nil
  | defs_cons d tl => defs_cons (open_rec_def k u d) (open_rec_defs k u tl)
  end.

Definition open_avar u a := open_rec_avar  0 u a.
Definition open_pth  u p := open_rec_pth   0 u p.
Definition open_typ  u t := open_rec_typ   0 u t.
Definition open_dec  u d := open_rec_dec   0 u d.
Definition open_decs u l := open_rec_decs  0 u l.
Definition open_trm  u e := open_rec_trm   0 u e.
Definition open_def  u d := open_rec_def   0 u d.
Definition open_defs u l := open_rec_defs  0 u l.

(* ###################################################################### *)
(** ** Free variables *)

Definition fv_avar (a: avar): vars :=
  match a with
  | avar_b i => \{}
  | avar_f x => \{x}
  end.

Definition fv_pth (p: pth): vars :=
  match p with
  | pth_var a => fv_avar a
  end.

Fixpoint fv_typ (T: typ) { struct T }: vars :=
  match T with
  | typ_bind Ds => fv_decs Ds
  | typ_sel p M => fv_pth p
  end
with fv_dec (D: dec) { struct D }: vars :=
  match D with
  | dec_typ _ T U => (fv_typ T) \u (fv_typ U)
  | dec_tyu _ T   => (fv_typ T)
  | dec_mtd _ T U => (fv_typ T) \u (fv_typ U)
  end
with fv_decs (Ds: decs) { struct Ds }: vars :=
  match Ds with
  | decs_nil          => \{}
  | decs_cons D Ds' => (fv_dec D) \u (fv_decs Ds')
  end.

Fixpoint fv_trm (t: trm): vars :=
  match t with
  | trm_var x        => (fv_avar x)
  | trm_new ds       => (fv_defs ds)
  | trm_call t1 m t2 => (fv_trm t1) \u (fv_trm t2)
  end
with fv_def (d: def): vars :=
  match d with
  | def_typ _ T U => (fv_typ T) \u (fv_typ U)
  | def_tyu _ U => (fv_typ U)
  | def_mtd _ T U u => (fv_typ T) \u (fv_typ U) \u (fv_trm u)
  end
with fv_defs(ds: defs): vars :=
  match ds with
  | defs_nil         => \{}
  | defs_cons d tl   => (fv_defs tl) \u (fv_def d)
  end.

Definition fv_ctx_types(G: ctx): vars := (fv_in_values (fun ct => match ct with typ_clo _ T => fv_typ T end) G).

(* ###################################################################### *)
(** ** Evaluation *)

Inductive val: Type :=
  | val_clo: env val -> defs -> val.

Definition vctx := env val.

Definition fv_ctx_values(H: vctx): vars := (fv_in_values (fun v => match v with val_clo _ ds => fv_defs ds end) H).

Inductive ev: vctx -> trm -> val -> Prop :=
| ev_var: forall H x v,
  binds x v H ->
  ev H (trm_var (avar_f x)) v
| ev_new: forall H ds,
  ev H (trm_new ds) (val_clo H ds)
| ev_call: forall H e1 m e2 H1 x1 ds1 body v2 x2 T1 T2 v,
  ev H e1 (val_clo H1 ds1) ->
  ev H e2 v2 ->
  x1 # H1 ->
  defs_has (open_defs x1 ds1) (def_mtd m T1 T2 body) ->
  x2 # H1 ->
  x2 <> x1 ->
  ev (H1 & (x1 ~ (val_clo H1 ds1)) & (x2 ~ v2)) (open_trm x2 body) v ->
  ev H (trm_call e1 m e2) v
.

(* ###################################################################### *)
(** ** Tactics *)

Ltac auto_specialize :=
  repeat match goal with
  | Impl: ?Cond ->            _ |- _ => let HC := fresh in
      assert (HC: Cond) by auto; specialize (Impl HC); clear HC
  | Impl: forall (_: ?Cond), _ |- _ => match goal with
      | p: Cond |- _ => specialize (Impl p)
      end
  end.

Ltac gather_vars :=
  let A := gather_vars_with (fun x: vars      => x         ) in
  let B := gather_vars_with (fun x: var       => \{ x }    ) in
  let C := gather_vars_with (fun x: ctx       => (dom x) \u (fv_ctx_types x)) in
  let D := gather_vars_with (fun x: vctx      => (dom x) \u (fv_ctx_values x)) in
  let E := gather_vars_with (fun x: avar      => fv_avar  x) in
  let F := gather_vars_with (fun x: trm       => fv_trm   x) in
  let G := gather_vars_with (fun x: def       => fv_def   x) in
  let H := gather_vars_with (fun x: defs      => fv_defs  x) in
  let I := gather_vars_with (fun x: typ       => fv_typ   x) in
  let J := gather_vars_with (fun x: dec       => fv_dec   x) in
  let K := gather_vars_with (fun x: decs      => fv_decs  x) in
  constr:(A \u B \u C \u D \u E \u F \u G \u H \u I \u J \u K).

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

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

(* ###################################################################### *)
(** ** Examples of Evaluation *)

Module EvExamples.

Definition typ_top := typ_bind decs_nil.
Definition m := labels.m.
Definition t0 := (trm_new defs_nil).
Definition v0 := (val_clo empty defs_nil).
Definition fm t := (trm_new (defs_cons (def_mtd m typ_top typ_top t) defs_nil)).
Definition vm t := (val_clo empty (defs_cons (def_mtd m typ_top typ_top t) defs_nil)).
Definition fi i := fm (trm_var (avar_b i)).
Definition vi i := vm (trm_var (avar_b i)).

Example ev1:
  ev empty t0 v0.
Proof.
  apply ev_new.
Qed.

Example ev2:
  ev empty (trm_call (fi 0) m t0) v0.
Proof.
  pick_fresh x1. pick_fresh x2.
  eapply ev_call with (x1:=x1) (x2:=x2) (H1:=empty); auto.
  apply ev_new.
  apply ev_new.
  unfold open_defs. simpl. apply defs_has_hit. apply defs_hasnt_nil.
  erewrite If_r; auto. compute. erewrite If_l; auto.
  apply ev_var; auto.
Qed.

Example ev3:
  ev empty (trm_call (fi 1) m t0) (vi 1).
Proof.
  pick_fresh x1. pick_fresh x2.
  eapply ev_call with (x1:=x1) (x2:=x2) (H1:=empty); auto.
  apply ev_new.
  apply ev_new.
  unfold open_defs. simpl. apply defs_has_hit. apply defs_hasnt_nil.
  erewrite If_l; auto. compute.
  apply ev_var; auto.
Qed.

Example ev4:
  exists x1 x2,
  ev empty (trm_call (fm t0) m t0)
     (val_clo (empty & (x1 ~ (vm t0)) & (x2 ~ v0)) defs_nil)
  .
Proof.
  pick_fresh x1. pick_fresh x2. exists x1 x2.
  eapply ev_call with (x1:=x1) (x2:=x2) (H1:=empty); auto.
  apply ev_new.
  apply ev_new.
  unfold open_defs. simpl. apply defs_has_hit. apply defs_hasnt_nil.
  compute. apply ev_new.
Qed.

End EvExamples.

(* ###################################################################### *)
(** ** Typing *)

Fixpoint def_to_dec (d: def): dec :=
  match d with
  | def_typ M TL TU => dec_typ M TL TU
  | def_tyu M TU => dec_tyu M TU
  | def_mtd m T1 T2 t => dec_mtd m T1 T2
  end
.
Fixpoint defs_to_decs (ds: defs): decs :=
  match ds with
  | defs_nil => decs_nil
  | defs_cons d ds => decs_cons (def_to_dec d) (defs_to_decs ds)
  end
.

Inductive same_typ: ctx -> typ -> typ -> ctx -> Prop :=
| same_rfl: forall G T,
  same_typ G T T G
| same_sel: forall G1 G2 x1 x2 M Gx1 Tx1 Gx2 Tx2,
  binds x1 (typ_clo Gx1 Tx1) G1 ->
  binds x2 (typ_clo Gx2 Tx2) G2 ->
  same_typ Gx1 Tx1 Tx2 Gx2 ->
  same_typ G1
           (typ_sel (pth_var (avar_f x1)) M)
           (typ_sel (pth_var (avar_f x2)) M)
           G2
| same_bind: forall G Ds,
  (* TODO: do we need to go in there? *)
  same_typ G (typ_bind Ds) (typ_bind Ds) G
.

Inductive exp: ctx -> typ -> decs -> ctx -> Prop :=
| exp_bind: forall G Ds,
  exp G (typ_bind Ds) Ds G
| exp_sel: forall G G' G'' p M TL TU Ds,
  pth_has G p (dec_typ M TL TU) G' ->
  exp G' TU Ds G'' ->
  exp G (typ_sel p M) Ds G''
with pth_has: ctx -> pth -> dec -> ctx -> Prop :=
| pth_has_any: forall G x Gx Tx Ds D G' x',
  binds x (typ_clo Gx Tx) G ->
  exp Gx Tx Ds G' ->
  decs_has Ds D ->
  x' = var_gen (dom G') ->
  pth_has G (pth_var (avar_f x)) (open_dec x' D) (G' & (x' ~ (typ_clo Gx Tx)))
.

Inductive stp: nat -> bool -> ctx -> typ -> typ -> ctx -> Prop :=
| stp_sel2: forall n1 n2 n3 G1 T1 G2 p M TL TU Gp,
  pth_has G2 p (dec_typ M TL TU) Gp ->
  stp n1 true Gp TL TU Gp ->
  stp n2 true G1 T1 TL Gp ->
  stp n3 true G1 T1 TU Gp ->
  stp (S (n1+n2+n3)) true G1 T1 (typ_sel p M) G2
| stp_sel1: forall n1 n2 G1 G2 T2 p M TL TU Gp,
  pth_has G1 p (dec_typ M TL TU) Gp ->
  stp n1 true Gp TL TU Gp ->
  stp n2 true Gp TU T2 G2 ->
  stp (S (n1+n2)) true G1 (typ_sel p M) T2 G2
| stp_sel1u: forall n1 G1 G2 T2 p M TU Gp,
  pth_has G1 p (dec_tyu M TU) Gp ->
  stp n1 true Gp TU T2 G2 ->
  stp (S n1) true G1 (typ_sel p M) T2 G2
| stp_selx: forall n1 n2 G1 G2 p1 p2 M TL1 TU1 TL2 TU2 Gp1 Gp2,
  pth_has G1 p1 (dec_typ M TL1 TU1) Gp1 ->
  pth_has G2 p2 (dec_typ M TL2 TU2) Gp2 ->
  stp n1 true Gp1 TL1 TU1 Gp1 ->
  stp n2 true Gp2 TL2 TU2 Gp2 ->
  same_typ Gp2 TL2 TL1 Gp1 ->
  same_typ Gp1 TU1 TU2 Gp2 ->
  stp (S (n1+n2)) true G1 (typ_sel p1 M) (typ_sel p2 M) G2
| stp_selxu: forall n1 G1 G2 p1 p2 M TU1 TU2 Gp1 Gp2,
  pth_has G1 p1 (dec_tyu M TU1) Gp1 ->
  pth_has G2 p2 (dec_tyu M TU2) Gp2 ->
  wf_typ Gp1 TU1 ->
  wf_typ Gp2 TU2 ->
  same_typ Gp1 TU1 TU2 Gp2 ->
  stp (S n1) true G1 (typ_sel p1 M) (typ_sel p2 M) G2
| stp_bind: forall n1 L G1 Ds1 G2 Ds2 G1A G1B G1C G1X G2A G2B G2C G2X,
  wf_typ G2 (typ_bind Ds2) ->
  G1 = G1A & G1B & G1C ->
  G1X = G1A & G1C ->
  G2 = G2A & G2B & G2C ->
  G2X = G2A & G2C ->
  (forall x, x \notin L ->
   sdcs n1
        (G1X & (x ~ typ_clo G1X (typ_bind Ds1)))
        (open_decs x Ds1)
        (open_decs x Ds2)
        (G2X & (x ~ typ_clo G1X (typ_bind Ds1)))
  ) ->
  stp (S n1) true G1 (typ_bind Ds1) (typ_bind Ds2) G2
| stp_transf: forall n1 n2 G1 G2 G3 T1 T2 T3,
  stp n1 false G1 T1 T2 G2 ->
  stp n2 false G2 T2 T3 G3 ->
  stp (S (n1+n2)) false G1 T1 T3 G3
| stp_wrapf: forall n1 G1 G2 T1 T2,
  stp n1 true G1 T1 T2 G2 ->
  stp (S n1) false G1 T1 T2 G2

with sdc: nat -> ctx -> dec -> dec -> ctx -> Prop :=
| sdc_typ: forall n1 n2 n3 n4 G1 G2 M TL1 TL2 TU1 TU2,
  stp n1 true G1 TL1 TU1 G1 ->
  stp n2 true G2 TL2 TU2 G2 ->
  stp n3 false G2 TL2 TL1 G1 ->
  stp n4 true G1 TU1 TU2 G2 ->
  sdc (S (n1+n2+n3+n4)) G1 (dec_typ M TL1 TU1) (dec_typ M TL2 TU2) G2
| sdc_tyu: forall n1 G1 G2 M TU1 TU2,
  stp n1 true G1 TU1 TU2 G2 ->
  sdc (S n1) G1 (dec_tyu M TU1) (dec_tyu M TU2) G2
| sdc_typu: forall n1 n2 G1 G2 M TL1 TU1 TU2,
  stp n1 true G1 TL1 TU1 G1 ->
  stp n2 true G1 TU1 TU2 G2 ->
  sdc (S (n1+n2)) G1 (dec_typ M TL1 TU1) (dec_tyu M TU2) G2
| sdc_mtd: forall n1 n2 G1 G2 m TL1 TL2 TU1 TU2,
  stp n1 false G2 TL2 TL1 G1 ->
  stp n2 true G1 TU1 TU2 G2 ->
  sdc (S (n1+n2)) G1 (dec_mtd m TL1 TU1) (dec_mtd m TL2 TU2) G2

with sdcs: nat -> ctx -> decs -> decs -> ctx -> Prop :=
| sdcs_nil: forall n1 G1 Ds1 G2,
  wf_decs G1 Ds1 ->
  sdcs (S n1) G1 Ds1 decs_nil G2
| sdcs_cons: forall n1 n2 G1 Ds1 G2 Ds2 D1 D2,
  decs_has Ds1 D1 ->
  sdc n1 G1 D1 D2 G2 ->
  sdcs n2 G1 Ds1 Ds2 G2 ->
  decs_hasnt Ds2 (label_of_dec D2) ->
  sdcs (S (n1+n2)) G1 Ds1 (decs_cons D2 Ds2) G2

with wf_typ: ctx -> typ -> Prop :=
| wf_sel: forall n1 G p M TL TU Gp,
  pth_has G p (dec_typ M TL TU) Gp ->
  stp n1 true Gp TL TU Gp ->
  wf_typ G (typ_sel p M)
| wf_selu: forall G p M TU Gp,
  pth_has G p (dec_tyu M TU) Gp ->
  wf_typ Gp TU ->
  wf_typ G (typ_sel p M)
| wf_bind: forall L G GA GB GC GX Ds,
  G = GA & GB & GC ->
  GX = GA & GC ->
  (forall x, x \notin L ->
   wf_decs (GX & (x ~ typ_clo GX (typ_bind Ds)))
           (open_decs x Ds)
  ) ->
  wf_typ G (typ_bind Ds)

with wf_dec: ctx -> dec -> Prop :=
| wf_dec_typ: forall n1 G M TL TU,
  stp n1 true G TL TU G ->
  wf_dec G (dec_typ M TL TU)
| wf_dec_tyu: forall G M TU,
  wf_typ G TU ->
  wf_dec G (dec_tyu M TU)
| wf_dec_mtd: forall G m TL TU,
  wf_typ G TL ->
  wf_typ G TU ->
  wf_dec G (dec_mtd m TL TU)

with wf_decs: ctx -> decs -> Prop :=
| wf_decs_nil: forall G,
  wf_decs G decs_nil
| wf_decs_cons: forall G Ds D,
  wf_dec G D ->
  wf_decs G Ds ->
  decs_hasnt Ds (label_of_dec D) ->
  wf_decs G (decs_cons D Ds)
.

Definition stpn b G1 T1 T2 G2 := exists n, stp n b G1 T1 T2 G2.
Definition sdcn G1 D1 D2 G2 := exists n, sdc n G1 D1 D2 G2.
Definition sdcsn G1 Ds1 Ds2 G2 := exists n, sdcs n G1 Ds1 Ds2 G2.

Inductive tc_trm: ctx -> trm -> typ -> Prop :=
| tc_var: forall G T x Gx Tx,
  binds x (typ_clo Gx Tx) G ->
  stpn true Gx Tx T G ->
  tc_trm G (trm_var (avar_f x)) T
| tc_new: forall L G ds Ds,
  defs_to_decs ds = Ds ->
  (forall z, z \notin L ->
   tc_defs (G & (z ~ (typ_clo G (typ_bind Ds))))
           (open_defs z ds) (open_decs z Ds)
  ) ->
  tc_trm G (trm_new ds) (typ_bind Ds)
| tc_call: forall G t1 m t2 T2 T,
  trm_has G t1 (dec_mtd m T2 T) ->
  tc_trm G t2 T2 ->
  tc_trm G (trm_call t1 m t2) T
| tc_sub: forall G t T TU,
  tc_trm G t T ->
  stpn true G T TU G ->
  tc_trm G t TU
with tc_def: ctx -> def -> dec -> Prop :=
| tc_def_typ: forall G M TL TU,
  stpn true G TL TU G ->
  tc_def G (def_typ M TL TU) (dec_typ M TL TU)
| tc_def_tyu: forall G M TU,
  wf_typ G TU ->
  tc_def G (def_tyu M TU) (dec_tyu M TU)
| tc_def_mtd: forall L G m T1 T2 t,
  wf_typ G T1 ->
  (forall x, x \notin L ->
   tc_trm (G & (x ~ (typ_clo G T1)))
          (open_trm x t) T2
  ) ->
  tc_def G (def_mtd m T1 T2 t) (dec_mtd m T1 T2)
with trm_has: ctx -> trm -> dec -> Prop :=
| trm_has_var: forall G x D Gp Dp,
  pth_has G (pth_var (avar_f x)) Dp Gp ->
  sdcn Gp Dp D G ->
  trm_has G (trm_var (avar_f x)) D
| trm_has_trm: forall L G G' t T Ds D,
  tc_trm G t T ->
  exp G T Ds G' ->
  decs_has Ds D ->
  (forall x, x \notin L ->
   x \notin fv_dec (open_dec x D)
  ) ->
  sdcn G' D D G ->
  trm_has G t D
with tc_defs: ctx -> defs -> decs -> Prop :=
| tc_defs_nil: forall G,
  tc_defs G defs_nil decs_nil
| tc_defs_cons: forall G d ds D Ds,
  tc_def G d D ->
  tc_defs G ds Ds ->
  tc_defs G (defs_cons d ds) (decs_cons D Ds)
.

Inductive tc_val: val -> ctyp -> Prop :=
| tc_val_clo: forall L H ds G Ds,
  tc_ctx H G ->
  Ds = defs_to_decs ds ->
  (forall z, z \notin L ->
   tc_defs (G & (z ~ (typ_clo G (typ_bind Ds))))
           (open_defs z ds) (open_decs z Ds)
  ) ->
  tc_val (val_clo H ds) (typ_clo G (typ_bind Ds))
with tc_ctx: vctx -> ctx -> Prop :=
| tc_ctx_empty:
  tc_ctx empty empty
| tc_ctx_rec: forall H G x v CT,
  tc_val v CT ->
  tc_ctx H G ->
  tc_ctx (H & (x ~ v)) (G & (x ~ CT))
.

Inductive wf_val: ctx -> val -> typ -> Prop :=
| wf_val_any: forall G v T Gv Tv,
  tc_val v (typ_clo Gv Tv) ->
  stpn true Gv Tv T G ->
  wf_val G v T
.

(* ###################################################################### *)
(** ** Induction principles *)

Scheme stp_mut_sub  := Induction for stp  Sort Prop
with   sdc_mut_sub  := Induction for sdc  Sort Prop
with   sdcs_mut_sub := Induction for sdcs Sort Prop.
Combined Scheme sub_mutind from stp_mut_sub, sdc_mut_sub, sdcs_mut_sub.

Scheme wf_typ_mut_wf  := Induction for wf_typ  Sort Prop
with   wf_dec_mut_wf  := Induction for wf_dec  Sort Prop
with   wf_decs_mut_wf := Induction for wf_decs Sort Prop.
Combined Scheme wf_mutind from wf_typ_mut_wf, wf_dec_mut_wf, wf_decs_mut_wf.

Scheme stp_mut_sw  := Induction for stp  Sort Prop
with   sdc_mut_sw  := Induction for sdc  Sort Prop
with   sdcs_mut_sw := Induction for sdcs Sort Prop
with   wf_typ_mut_sw  := Induction for wf_typ  Sort Prop
with   wf_dec_mut_sw  := Induction for wf_dec  Sort Prop
with   wf_decs_mut_sw := Induction for wf_decs Sort Prop.
Combined Scheme sw_mutind from stp_mut_sw, sdc_mut_sw, sdcs_mut_sw, wf_typ_mut_sw, wf_dec_mut_sw, wf_decs_mut_sw.

Scheme exp_mut_ep     := Induction for exp Sort Prop
with   pth_has_mut_ep := Induction for pth_has Sort Prop.
Combined Scheme ep_mutind from exp_mut_ep, pth_has_mut_ep.

(* ###################################################################### *)
(** ** Properties *)

Theorem sub_reg:
  (forall n b G1 T1 T2 G2, stp n b G1 T1 T2 G2 -> wf_typ G1 T1 /\ wf_typ G2 T2) /\
  (forall n G1 D1 D2 G2, sdc n G1 D1 D2 G2 -> wf_dec G1 D1 /\ wf_dec G2 D2) /\
  (forall n G1 Ds1 Ds2 G2, sdcs n G1 Ds1 Ds2 G2 -> wf_decs G1 Ds1 /\ wf_decs G2 Ds2).
Proof.
  apply sub_mutind; intros.
  - (* T1 <: p.M -- sel2 *)
    split.
    + inversion H0. assumption.
    + eapply wf_sel. apply p0. eassumption.
  - (* p.M <: T2 -- sel1 *)
    split.
    + eapply wf_sel. apply p0. eassumption.
    + inversion H0. assumption.
  - (* p.M <: T2 -- sel1u *)
    split.
    + eapply wf_selu. apply p0. inversion H. assumption.
    + inversion H. assumption.
  - (* p.M <: p.M -- selx *)
    split.
    + eapply wf_sel. apply p. eassumption.
    + eapply wf_sel. apply p0. eassumption.
  - (* p.M <: p.M -- selxu *)
    split.
    + eapply wf_selu. apply p. assumption.
    + eapply wf_selu. apply p0. assumption.
  - (* bind *)
    split.
    + apply wf_bind with (L:=L) (GA:=G1A) (GB:=G1B) (GC:=G1C) (GX:=G1X); try assumption.
      intros x Frx.
      specialize (H x Frx). inversion H. assumption.
    + assumption.
  - (* transf *)
    split.
    + inversion H. assumption.
    + inversion H0. assumption.
  - (* wrapf *)
    assumption.
  - (* typ *)
    split.
    + eapply wf_dec_typ. eassumption.
    + eapply wf_dec_typ. eassumption.
  - (* tyu *)
    split.
    + apply wf_dec_tyu. inversion H. assumption.
    + apply wf_dec_tyu. inversion H. assumption.
  - (* typu *)
    split.
    + eapply wf_dec_typ. eassumption.
    + apply wf_dec_tyu. inversion H0. assumption.
  - (* mtd *)
    split.
    + apply wf_dec_mtd. inversion H. assumption. inversion H0. assumption.
    + apply wf_dec_mtd. inversion H. assumption. inversion H0. assumption.
  - (* Ds1 <: {} -- nil *)
    split.
    + assumption.
    + apply wf_decs_nil.
  - (* Ds1 <: D2::Ds2 -- cons *)
    split.
    + inversion H0. assumption.
    + apply wf_decs_cons.
        inversion H. assumption.
        inversion H0. assumption.
        assumption.
Qed.

Definition stp_reg := proj1 sub_reg.
Definition sdc_reg := proj1 (proj2 sub_reg).
Definition sdcs_reg := proj2 (proj2 sub_reg).

Lemma stp_reg1: forall n b G1 T1 T2 G2,
  stp n b G1 T1 T2 G2 ->
  wf_typ G1 T1.
Proof.
  intros n b G1 T1 T2 G2 H.
  apply (proj1 (stp_reg H)).
Qed.

Lemma sdc_reg2: forall n G1 D1 D2 G2,
  sdc n G1 D1 D2 G2 ->
  wf_dec G2 D2.
Proof.
  intros n G1 Ds1 Ds2 G2 H.
  apply (proj2 (sdc_reg H)).
Qed.

Lemma sdcs_reg1: forall n G1 Ds1 Ds2 G2,
  sdcs n G1 Ds1 Ds2 G2 ->
  wf_decs G1 Ds1.
Proof.
  intros n G1 Ds1 Ds2 G2 H.
  apply (proj1 (sdcs_reg H)).
Qed.

Lemma decs_has_or_hasnt: forall Ds D D',
  decs_hasnt Ds (label_of_dec D) ->
  decs_has Ds D' ->
  label_of_dec D <> label_of_dec D'.
Proof.
  intros Ds D D' H H'.
  induction H.
  + inversion H'.
  + inversion H'; subst.
    - congruence.
    - apply IHdecs_hasnt. assumption.
Qed.

Lemma sdcs_cons1: forall n G1 Ds1 Ds2 G2 D1,
  sdcs n G1 Ds1 Ds2 G2 ->
  wf_dec G1 D1 ->
  decs_hasnt Ds1 (label_of_dec D1) ->
  sdcs n G1 (decs_cons D1 Ds1) Ds2 G2.
Proof.
  intros.
  induction H.
  + apply sdcs_nil. apply wf_decs_cons; assumption.
  + apply sdcs_cons with (D1:=D0) (n1:=n1).
    - apply decs_has_skip. assumption.
      apply decs_has_or_hasnt with (Ds:=Ds1); assumption.
    - assumption.
    - apply IHsdcs. assumption. assumption.
    - assumption.
Qed.

(* Problem with cofinite quantification and index-based induction scheme. *)
Axiom sdcs_cofinite_switch: forall L Ds1 Ds2 G1X G2X,
  (forall x, x \notin L ->
   sdcsn
        (G1X & (x ~ typ_clo G1X (typ_bind Ds1)))
        (open_decs x Ds1)
        (open_decs x Ds2)
        (G2X & (x ~ typ_clo G1X (typ_bind Ds1)))) ->
  exists n,
  (forall x, x \notin L ->
   sdcs n
        (G1X & (x ~ typ_clo G1X (typ_bind Ds1)))
        (open_decs x Ds1)
        (open_decs x Ds2)
        (G2X & (x ~ typ_clo G1X (typ_bind Ds1)))).

Theorem sub_refl:
  (forall n b G1 T1 T2 G2, stp n b G1 T1 T2 G2 -> stpn b G1 T1 T1 G1 /\ stpn b G2 T2 T2 G2) /\
  (forall n G1 D1 D2 G2, sdc n G1 D1 D2 G2 -> sdcn G1 D1 D1 G1 /\ sdcn G2 D2 D2 G2) /\
  (forall n G1 Ds1 Ds2 G2, sdcs n G1 Ds1 Ds2 G2 -> sdcsn G1 Ds1 Ds1 G1 /\ sdcsn G2 Ds2 Ds2 G2) /\
  (forall G T, wf_typ G T -> stpn true G T T G) /\
  (forall G D, wf_dec G D -> sdcn G D D G) /\
  (forall G Ds, wf_decs G Ds -> sdcsn G Ds Ds G).
Proof.
  apply sw_mutind; intros.
  - (* T1 <: p.M -- sel2 *)
    split.
    + inversion H0. assumption.
    + exists (S (n1+n1)). eapply stp_selx.
      apply p0. apply p0.
      assumption. assumption.
      apply same_rfl. apply same_rfl.
  - (* p.M <: T2 -- sel1 *)
    split.
    + exists (S (n1+n1)). eapply stp_selx.
      apply p0. apply p0.
      assumption. assumption.
      apply same_rfl. apply same_rfl.
    + inversion H0. assumption.
  - (* p.M <: T2 -- sel1u *)
    split.
    + assert (wf_typ Gp TU) as HwfU. {
        inversion H as [H1 H2].
        inversion H1 as [n H1'].
        apply stp_reg1 with (n:=n) (b:=true) (T2:=TU) (G2:=Gp).
        assumption.
      }
      exists (S 0).
      eapply stp_selxu.
      apply p0. apply p0.
      assumption. assumption.
      apply same_rfl.
    + inversion H. assumption.
  - (* p.M <: p.M -- selx *)
    split.
    + exists (S (n1+n1)). eapply stp_selx.
      apply p. apply p.
      assumption. assumption.
      apply same_rfl. apply same_rfl.
    + exists (S (n2+n2)). eapply stp_selx.
      apply p0. apply p0.
      assumption. assumption.
      apply same_rfl. apply same_rfl.
  - (* p.M <: p.M -- selxu *)
    split.
    + exists (S 0). eapply stp_selxu.
      apply p. apply p.
      assumption. assumption.
      apply same_rfl.
    + exists (S 0). eapply stp_selxu.
      apply p0. apply p0.
      assumption. assumption.
      apply same_rfl.
  - (* bind *)
    split.
    + assert (forall x, x \notin L ->
       sdcsn (G1X & x ~ typ_clo G1X (typ_bind Ds1))
         (open_decs x Ds1) (open_decs x Ds1)
         (G1X & x ~ typ_clo G1X (typ_bind Ds1))) as A. {
        intros x Fr. specialize (H0 x Fr). inversion H0.
        assumption.
      }
      apply sdcs_cofinite_switch in A. inversion A as [n' A'].
      exists (S n').
      apply stp_bind with (L:=L)
        (G1A:=G1A) (G1B:=G1B) (G1C:=G1C) (G1X:=G1X)
        (G2A:=G1A) (G2B:=G1B) (G2C:=G1C) (G2X:=G1X); auto.
      apply wf_bind with (L:=L)
        (GA:=G1A) (GB:=G1B) (GC:=G1C) (GX:=G1X); auto.
      intros x Frx. eapply sdcs_reg1. specialize (s x Frx). apply s.
    + assumption.
  - (* transf *)
    split.
    + inversion H. inversion H1 as [n H1']. exists n. assumption.
    + inversion H0. assumption.
  - (* wrapf *)
    split.
    + inversion H. inversion H0 as [n H0']. exists (S n). apply stp_wrapf. assumption.
    + inversion H. inversion H1 as [n H1']. exists (S n). apply stp_wrapf. assumption.
  - (* sdc_typ *)
    split.
    + inversion H1 as [_ HL]. inversion HL as [nl HL'].
      inversion H2 as [HU _]. inversion HU as [nu HU'].
      exists (S (n1+n1+nl+nu)). apply sdc_typ; assumption.
    + inversion H1 as [HL _]. inversion HL as [nl HL'].
      inversion H2 as [_ HU]. inversion HU as [nu HU'].
      exists (S (n2+n2+nl+nu)). apply sdc_typ; assumption.
  - (* sdc_tyu *)
    split.
    + inversion H as [HU _]. inversion HU as [nu HU'].
      exists (S nu). apply sdc_tyu; assumption.
    + inversion H as [_ HU]. inversion HU as [nu HU'].
      exists (S nu). apply sdc_tyu; assumption.
  - (* sdc_typu *)
    split.
    + inversion H as [HL HU].
      inversion HL as [nl HL'].
      inversion HU as [nu HU'].
      exists (S (n1+n1+(S nl)+nu)). apply sdc_typ; try assumption.
      apply stp_wrapf. assumption.
    + inversion H0 as [_ HU]. inversion HU as [nu HU'].
      exists (S nu). apply sdc_tyu. assumption.
  - (* sdc_mtd *)
    split.
    + inversion H as [_ HL]. inversion HL as [nl HL'].
      inversion H0 as [HU _]. inversion HU as [nu HU'].
      exists (S (nl+nu)). apply sdc_mtd; assumption.
    + inversion H as [HL _]. inversion HL as [nl HL'].
      inversion H0 as [_ HU]. inversion HU as [nu HU'].
      exists (S (nl+nu)). apply sdc_mtd; assumption.
  - (* Ds1 <: {} -- nil *)
    split.
    + assumption.
    + exists (S 0). apply sdcs_nil. apply wf_decs_nil.
  - (* Ds1 <: D2::Ds2 -- cons *)
    split.
    + inversion H0. assumption.
    + inversion H0 as [_ HDs2]. inversion HDs2 as [n2' HDs2'].
      inversion H as [_ HD2]. inversion HD2 as [n1' HD2'].
      exists (S (n1'+n2')).
      apply sdcs_cons with (D1:=D2) (n1:=n1').
        apply decs_has_hit; assumption.
        assumption.
        apply sdcs_cons1.
          assumption.
          eapply sdc_reg2. apply s.
          assumption.
          assumption.
  - (* wf_sel *)
    exists (S (n1+n1)).
    apply stp_selx with (TL1:=TL) (TL2:=TL) (TU1:=TU) (TU2:=TU) (Gp1:=Gp) (Gp2:=Gp);
    try assumption; try solve [apply same_rfl].
  - (* wf_selu *)
    exists (S 0).
    apply stp_selxu with (TU1:=TU) (TU2:=TU) (Gp1:=Gp) (Gp2:=Gp);
    try assumption; try solve [apply same_rfl].
  - (* wf_bind *)
    apply sdcs_cofinite_switch in H. inversion H as [n' H'].
    exists (S n').
    apply stp_bind with (L:=L)
      (G1A:=GA) (G1B:=GB) (G1C:=GC) (G1X:=GX)
      (G2A:=GA) (G2B:=GB) (G2C:=GC) (G2X:=GX);
    try assumption.
    apply wf_bind with (L:=L)
      (GA:=GA) (GB:=GB) (GC:=GC) (GX:=GX);
    assumption.
  - (* wf_dec_typ *)
    inversion H as [HL HU].
    inversion HL as [nl HL'].
    inversion HU as [nu HU'].
    exists (S (n1+n1+(S nl)+nu)). apply sdc_typ; try assumption.
    apply stp_wrapf. assumption.
  - (* wf_dec_tyu *)
    inversion H as [nu HU'].
    exists (S nu). apply sdc_tyu; assumption.
  - (* wf_dec_mtd *)
    inversion H as [nl HL'].
    inversion H0 as [nu HU'].
    exists (S ((S nl)+nu)).
    apply sdc_mtd; try assumption.
    apply stp_wrapf. assumption.
  - (* wf_decs_nil *)
    exists (S 0). apply sdcs_nil. apply wf_decs_nil.
  - (* wf_decs_cons *)
    inversion H0 as [n2 HDs'].
    inversion H as [n1 HD'].
    exists (S (n1+n2)).
    apply sdcs_cons with (D1:=D) (n1:=n1); try assumption.
    + apply decs_has_hit. assumption.
    + apply sdcs_cons1; try assumption.
Qed.

Theorem pth_has_extending:
  (forall G p D Gp, pth_has G p D Gp ->
   forall GA GB GC,
     G = GA & GC ->
     pth_has (GA & GB & GC) p D Gp
  ).
Proof.
  intros. inversion H. subst.
  apply pth_has_any with (Ds:=Ds); auto.
  subst. apply binds_weaken.
    assumption.
    admit (* ok (GA & GB & GC) *).
Qed.

Theorem sub_extending:
  (forall n b G1 T1 T2 G2, stp n b G1 T1 T2 G2 ->
   forall G1A G1B G1C G2A G2B G2C,
     G1 = G1A & G1C ->
     G2 = G2A & G2C ->
     stp n b (G1A & G1B & G1C) T1 T2 (G2A & G2B & G2C)
  ) /\
  (forall n G1 D1 D2 G2, sdc n G1 D1 D2 G2 ->
   forall G1A G1B G1C G2A G2B G2C,
     G1 = G1A & G1C ->
     G2 = G2A & G2C ->
     sdc n (G1A & G1B & G1C) D1 D2 (G2A & G2B & G2C)
  ) /\
  (forall n G1 Ds1 Ds2 G2, sdcs n G1 Ds1 Ds2 G2 ->
   forall G1A G1B G1C G2A G2B G2C,
     G1 = G1A & G1C ->
     G2 = G2A & G2C ->
     sdcs n (G1A & G1B & G1C) Ds1 Ds2 (G2A & G2B & G2C)
  ) /\
  (forall G T, wf_typ G T ->
   forall GA GB GC,
     G = GA & GC ->
     wf_typ (GA & GB & GC) T
  ) /\
  (forall G D, wf_dec G D ->
   forall GA GB GC,
     G = GA & GC ->
     wf_dec (GA & GB & GC) D
  ) /\
  (forall G Ds, wf_decs G Ds ->
   forall GA GB GC,
     G = GA & GC ->
     wf_decs (GA & GB & GC) Ds
  ).
Proof.
  apply sw_mutind; intros.
  - (* stp_sel2 *)
    apply stp_sel2 with (TL:=TL) (TU:=TU) (Gp:=Gp & empty & empty); auto.
    apply pth_has_extending with (G:=G2).
    rewrite concat_empty_r. rewrite concat_empty_r. assumption.
    assumption.
    rewrite concat_empty_r. rewrite concat_empty_r. assumption.
    apply H0; try assumption.
    rewrite concat_empty_r. reflexivity.
    apply H1; try assumption.
    rewrite concat_empty_r. reflexivity.
  - (* stp_sel1 *)
    apply stp_sel1 with (TL:=TL) (TU:=TU) (Gp:= Gp & empty & empty); auto.
    apply pth_has_extending with (G:=G1).
    rewrite concat_empty_r. rewrite concat_empty_r. assumption.
    assumption.
    rewrite concat_empty_r. rewrite concat_empty_r. assumption.
    apply H0; try assumption.
    rewrite concat_empty_r. reflexivity.
  - (* stp_sel1u *)
    apply stp_sel1u with (TU:=TU) (Gp:= Gp & empty & empty); auto.
    apply pth_has_extending with (G:=G1).
    rewrite concat_empty_r. rewrite concat_empty_r. assumption.
    assumption.
    apply H; try assumption.
    rewrite concat_empty_r. reflexivity.
  - (* stp_selx *)
    apply stp_selx
    with (TL1:=TL1) (TL2:=TL2) (TU1:=TU1) (TU2:=TU2) (Gp1:=Gp1) (Gp2:=Gp2);
    auto.
    apply pth_has_extending with (G:=G1); assumption.
    apply pth_has_extending with (G:=G2); assumption.
  - (* stp_selxu *)
    apply stp_selxu
    with (TU1:=TU1) (TU2:=TU2) (Gp1:=Gp1) (Gp2:=Gp2);
    auto.
    apply pth_has_extending with (G:=G1); assumption.
    apply pth_has_extending with (G:=G2); assumption.
  - (* stp_bind *)
    subst.
    apply stp_bind with (L:=L)
      (G1A:=G1A) (G1B:=G2B & G1B0) (G1C:=G1C) (G1X:=G1A & G1C)
      (G2A:=G2A) (G2B:=G2B & G2B0) (G2C:=G2C) (G2X:=G2A & G2C).
    apply H. assumption.
    admit (* re-ordering env concats *). reflexivity.
    admit (* ditto *). reflexivity.
    assumption.
  - (* stp_transf *)
    apply stp_transf with (T2:=T2) (G2:=G2 & empty & empty); auto.
    apply H; try assumption.
    rewrite concat_empty_r. reflexivity.
    apply H0; try assumption.
    rewrite concat_empty_r. reflexivity.
  - (* stp_wrapf *)
    apply stp_wrapf; auto.
  - (* sdc_typ *)
    apply sdc_typ; auto.
  - (* sdc_tyu *)
    apply sdc_tyu; auto.
  - (* sdc_typu *)
    apply sdc_typu; auto.
  - (* sdc_mtd *)
    apply sdc_mtd; auto.
  - (* sdcs_nil *)
    apply sdcs_nil; auto.
  - (* sdcs_cons *)
    apply sdcs_cons with (D1:=D1) (n1:=n1); auto.
  - (* wf_typ *)
    apply wf_sel with (n1:=n1) (TL:=TL) (TU:=TU) (Gp:=Gp); auto.
    apply pth_has_extending with (G:=G); assumption.
  - (* wf_tyu *)
    apply wf_selu with (TU:=TU) (Gp:=Gp); auto.
    apply pth_has_extending with (G:=G); assumption.
  - (* wf_bind *)
    subst.
    apply wf_bind with (L:=L)
      (GA:=GA) (GB:=GB & GB0) (GC:=GC) (GX:=GA & GC).
    admit (* re-ordering env concats *). reflexivity.
    assumption.
  - (* wf_dec_typ *)
    apply wf_dec_typ with (n1:=n1); auto.
  - (* wf_dec_tyu *)
    apply wf_dec_tyu; auto.
  - (* wf_dec_mtd *)
    apply wf_dec_mtd; auto.
  - (* wf_decs_nil *)
    apply wf_decs_nil; auto.
  - (* wf_decs_cons *)
    apply wf_decs_cons; auto.
Qed.

Lemma lookup_unique: forall {A} x G (a: A) (a': A),
  binds x a  G ->
  binds x a' G ->
  a' = a.
Proof.
  introv Hb1 Hb2.
  inversion Hb1 as [Hb1'].
  inversion Hb2 as [Hb2'].
  rewrite Hb2' in Hb1'.
  inversion Hb1'.
  reflexivity.
Qed.

Lemma decs_has_unique: forall Ds D1 D2,
  decs_has Ds D1 ->
  decs_has Ds D2 ->
  label_of_dec D1 = label_of_dec D2 ->
  D1 = D2.
Proof.
  introv H1. induction H1.
  - introv H2 Eq. inversions H2.
    * reflexivity.
    * rewrite Eq in H5. false H5. reflexivity.
  - introv H2 Eq. inversions H2.
    * rewrite Eq in H. false H. reflexivity.
    * apply (IHdecs_has H4 Eq).
Qed.

Lemma ep_unique:
  (forall G T Ds Ge, exp G T Ds Ge ->
   forall Ds' Ge',
   exp G T Ds' Ge' ->
   Ds' = Ds /\ Ge' = Ge) /\
  (forall G p D Gp, pth_has G p D Gp ->
   forall D' Gp',
   pth_has G p D' Gp' ->
   label_of_dec D' = label_of_dec D ->
   D' = D /\ Gp' = Gp).
Proof.
  apply ep_mutind.
  - (* exp_bind *)
    intros; inversion H; subst; split; reflexivity.
  - (* exp_sel *)
    intros G Gp Gpe p M TL TU Ds Hp HIp He HIe Ds' Ge' H.
    inversion H; subst.
    assert (dec_typ M TL0 TU0 = dec_typ M TL TU /\ G' = Gp) as A.
    apply HIp; try assumption.
    compute. reflexivity.
    inversion A as [A1 A2]. inversion A1. subst.
    apply HIe. assumption.
  - (* pth_has_any *)
    intros G x Gx Tx Ds D Gp z Hb He HIe Hd Hz D' Gp' H Hl.
    inversion H. subst.
    assert (typ_clo Gx0 Tx0 = typ_clo Gx Tx) as A. {
      eapply lookup_unique. apply Hb. assumption.
    }
    inversions A.
    assert (Ds0 = Ds /\ G' = Gp) as A. {
      apply HIe. assumption.
    }
    inversions A.
    assert (D0 = D) as A. {
      apply decs_has_unique with (Ds:=Ds); try assumption.
      induction D; induction D0; compute; compute in Hl; apply Hl.
    }
    subst.
    split; reflexivity.
Qed.

Theorem pth_has_unique: forall G p D Gp D' Gp',
  pth_has G p D Gp ->
  pth_has G p D' Gp' ->
  label_of_dec D' = label_of_dec D ->
  D' = D /\ Gp' = Gp.
Proof.
  introv H1.
  apply (proj2 ep_unique).
  apply H1.
Qed.

(* same_typ lemmas *)

Lemma same_typ_sym: forall G1 T1 G2 T2,
  same_typ G1 T1 T2 G2 ->
  same_typ G2 T2 T1 G1.
Proof.
  introv H. induction H.
  - apply same_rfl.
  - eapply same_sel; eassumption.
  - apply same_bind.
Qed.

Lemma same_stp2: forall n G1 T1 G2 T2 G3 T3,
  stp n true G1 T1 T2 G2 ->
  same_typ G2 T2 T3 G3 ->
  stp n true G1 T1 T3 G3.
Proof.
  introv Hstp Hsame. gen G1 T1. induction Hsame; intros; try assumption.
  (* tricky *)
  admit.
Qed.

Lemma same_stp1: forall n G1 T1 G2 T2 G3 T3,
  stp n true G2 T2 T3 G3 ->
  same_typ G1 T1 T2 G2 ->
  stp n true G1 T1 T3 G3.
Proof.
  admit.
Qed.

Lemma same_typ_trans: forall G1 T1 G2 T2 G3 T3,
  same_typ G1 T1 T2 G2 ->
  same_typ G2 T2 T3 G3 ->
  same_typ G1 T1 T3 G3.
Proof.
  introv H12 H23. induction H12; try assumption.
  (* tricky *)
  admit.
Qed.

(* Transivity *)

Definition stp_trans_on n12 n23 :=
  forall G1 T1 G2 T2 G3 T3,
  stp n12 true G1 T1 T2 G2 ->
  stp n23 true G2 T2 T3 G3 ->
  stpn true G1 T1 T3 G3.

Definition sdc_trans_on n12 n23 :=
  forall G1 D1 G2 D2 G3 D3,
  sdc n12 G1 D1 D2 G2 ->
  sdc n23 G2 D2 D3 G3 ->
  sdcn G1 D1 D3 G3.

Definition sdcs_trans_on n12 n23 :=
  forall G1 Ds1 G2 Ds2 G3 Ds3,
  sdcs n12 G1 Ds1 Ds2 G2 ->
  sdcs n23 G2 Ds2 Ds3 G3 ->
  sdcsn G1 Ds1 Ds3 G3.

Definition trans_up (P: nat -> nat -> Prop) n :=
  forall n12 n23, n12 + n23 <= n ->
  P n12 n23.

Lemma trans_le: forall P n n12 n23,
  trans_up P n ->
  n12 + n23 <= n ->
  P n12 n23.
Proof.
  introv H Heq. unfold trans_up in H. apply H. auto.
Qed.

Lemma stpn_sel2: forall G1 T1 G2 p M TL TU Gp,
  pth_has G2 p (dec_typ M TL TU) Gp ->
  stpn true Gp TL TU Gp ->
  stpn true G1 T1 TL Gp ->
  stpn true G1 T1 TU Gp ->
  stpn true G1 T1 (typ_sel p M) G2.
Proof.
  intros.
  inversion H0 as [n1 H1'].
  inversion H1 as [n2 H2'].
  inversion H2 as [n3 H3'].
  exists (S (n1+n2+n3)).
  eapply stp_sel2; try eassumption.
Qed.

Lemma stpn_sel1: forall G1 G2 T2 p M TL TU Gp,
  pth_has G1 p (dec_typ M TL TU) Gp ->
  stpn true Gp TL TU Gp ->
  stpn true Gp TU T2 G2 ->
  stpn true G1 (typ_sel p M) T2 G2.
Proof.
  intros. inversion H0 as [n1 H1']. inversion H1 as [n2 H2'].
  exists (S (n1+n2)).
  eapply stp_sel1; try eassumption.
Qed.

Lemma stpn_sel1u: forall G1 G2 T2 p M TU Gp,
  pth_has G1 p (dec_tyu M TU) Gp ->
  stpn true Gp TU T2 G2 ->
  stpn true G1 (typ_sel p M) T2 G2.
Proof.
  intros. inversion H0 as [n1 H1'].
  exists (S n1).
  eapply stp_sel1u; try eassumption.
Qed.

Lemma sub_trans: forall n,
  trans_up stp_trans_on n /\
  trans_up sdc_trans_on n /\
  trans_up sdcs_trans_on n.
Proof.
  intros n.
  unfold trans_up.
  unfold stp_trans_on.
  unfold sdc_trans_on.
  unfold sdcs_trans_on.
  induction n.
  - split; try split; intros;
    assert (n12 = 0) by omega;
    assert (n23 = 0) by omega;
    subst;
    inversion H0; inversion H1.
  - inversion IHn as [IHn_stp [IHn_sdc IHn_sdcs]].
    split; try split;
    intros n12 n23 Hneq G1 T1 G2 T2 G3 T3 HS12 HS23;

    inversion HS12; inversion HS23; subst;
    (* 36 cases total *)
    (* 6 cases, stp_sel2 right *)
    try solve [eapply stpn_sel2; [
        eassumption |
        eexists; eassumption |
        eapply trans_le in IHn_stp; [
            eapply IHn_stp; eassumption |
            omega
        ] |
        eapply trans_le in IHn_stp; [
            eapply IHn_stp; eassumption |
            omega
        ]
    ]];
    (* 5 cases, stp_sel1 left *)
    try solve [eapply stpn_sel1; [
        eassumption |
        eexists; eassumption |
        eapply trans_le in IHn_stp; [
            eapply IHn_stp; eassumption |
            omega
        ]
    ]];
    (* 5 cases, stp_sel1u left *)
    try solve [eapply stpn_sel1u; [
        eassumption |
        eapply trans_le in IHn_stp; [
            eapply IHn_stp; eassumption |
            omega
        ]
    ]].

  + (* sel2 - sel1 *)
    inversions H14.
    assert (dec_typ M TL0 TU0 = dec_typ M TL TU /\ Gp0 = Gp) as A. {
      eapply pth_has_unique; try eassumption.
      compute. reflexivity.
    }
    inversion A as [A1 A2]. inversions A1. clear A.
    eapply trans_le in IHn_stp.
    eapply IHn_stp. apply H2. eassumption.
    omega.

  + (* sel2 - sel1u *)
    inversions H13.
    assert (dec_tyu M TU0 = dec_typ M TL TU /\ Gp0 = Gp) as A. {
      eapply pth_has_unique; try eassumption.
      compute. reflexivity.
    }
    inversion A as [A1 A2]. inversion A1. (* contradiction *)

  + (* sel2 - selx *)
    inversions H17.
    assert (dec_typ M TL1 TU1 = dec_typ M TL TU /\ Gp1 = Gp) as A. {
      eapply pth_has_unique; try eassumption.
      compute. reflexivity.
    }
    inversion A as [A1 A2]. inversions A1. clear A.

    eexists. eapply stp_sel2; try eassumption.

    apply same_stp2 with (T2:=TL) (G2:=Gp); try eassumption.
    apply same_typ_sym. assumption.

    apply same_stp2 with (T2:=TU) (G2:=Gp); eassumption.

  + (* sel2 - selxu *)
    inversions H16.
    assert (dec_tyu M TU1 = dec_typ M TL TU /\ Gp1 = Gp) as A. {
      eapply pth_has_unique; try eassumption.
      compute. reflexivity.
    }
    inversion A as [A1 A2]. inversion A1.

  + inversion H17.

  + (* selx - sel1 *)
    inversions H16.
    assert (dec_typ M TL2 TU2 = dec_typ M TL TU /\ Gp2 = Gp) as A. {
      eapply pth_has_unique; try eassumption.
      compute. reflexivity.
    }
    inversion A as [A1 A2]. inversions A1. clear A.

    eexists. eapply stp_sel1; try eassumption.

    apply same_stp1 with (T2:=TU) (G2:=Gp); try eassumption.

  + (* selxu - sel1 *)
    inversions H15.
    assert (dec_tyu M TU = dec_typ M TL2 TU2 /\ Gp = Gp2) as A. {
      eapply pth_has_unique; try eassumption.
      compute. reflexivity.
    }
    inversion A as [A1 A2]. inversion A1.

  + (* selx - selx *)
    inversions H19.
    assert (dec_typ M TL2 TU2 = dec_typ M TL0 TU0 /\ Gp2 = Gp0) as A. {
      eapply pth_has_unique; try eassumption.
      compute. reflexivity.
    }
    inversion A as [A1 A2]. inversions A1. clear A.

    eexists. eapply stp_selx; try eassumption.
    apply same_typ_trans with (T2:=TL0) (G2:=Gp0); assumption.
    apply same_typ_trans with (T2:=TU0) (G2:=Gp0); assumption.

  + (* selx - selxu *)
    inversions H18.
    assert (dec_tyu M TU0 = dec_typ M TL2 TU2 /\ Gp0 = Gp2) as A. {
      eapply pth_has_unique; try eassumption.
      compute. reflexivity.
    }
    inversion A as [A1 A2]. inversion A1.

  + inversion H19.

  + (* selx - sel1u *)
    inversions H15.
    assert (dec_tyu M TU2 = dec_typ M TL TU /\ Gp2 = Gp) as A. {
      eapply pth_has_unique; try eassumption.
      compute. reflexivity.
    }
    inversion A as [A1 A2]. inversion A1.

  + (* selxu - sel1u *)
    inversions H14.
    assert (dec_tyu M TU2 = dec_tyu M TU /\ Gp2 = Gp) as A. {
      eapply pth_has_unique; try eassumption.
      compute. reflexivity.
    }
    inversion A as [A1 A2]. inversions A1. clear A.

    eexists. eapply stp_sel1u; try eassumption.

    apply same_stp1 with (T2:=TU) (G2:=Gp); try eassumption.

  + (* selxu - selx *)
    inversions H18.
    assert (dec_tyu M TU2 = dec_typ M TL1 TU0 /\ Gp2 = Gp0) as A. {
      eapply pth_has_unique; try eassumption.
      compute. reflexivity.
    }
    inversion A as [A1 A2]. inversion A1.

  + (* selxu - selxu *)
    inversions H17.
    assert (dec_tyu M TU2 = dec_tyu M TU0 /\ Gp2 = Gp0) as A. {
      eapply pth_has_unique; try eassumption.
      compute. reflexivity.
    }
    inversion A as [A1 A2]. inversions A1. clear A.

    exists (S 0). eapply stp_selxu; try eassumption.
    apply same_typ_trans with (T2:=TU0) (G2:=Gp0); assumption.

  + inversion H18.

  + inversion H16.

  + inversion H15.

  + inversion H19.

  + inversion H18.

  + (* bind - bind *)
    inversions H19.
    exists (S n).
    apply stp_bind with (L:=L \u L0) (G1A:=G1A) (G1B:=G1B) (G1C:=G1C) (G1X:=G1A & G1C) (G2A:=G2A0) (G2B:=G2B0) (G2C:=G2C0) (G2X:=G2A0 & G2C0); try assumption; try reflexivity.
    intros x Frx.
    assert (x \notin L) as FrL by auto.
    assert (x \notin L0) as FrL0 by auto.
    specialize (H4 x FrL). specialize (H15 x FrL0).
    admit.

  + (* sdc_typ - sdc_typ *)
    inversions H14.
    assert (stpn true G1 TU1 TU3 G3) as HU13. {
     eapply trans_le in IHn_stp; [
        eapply IHn_stp; eassumption |
        omega
      ].
    }
    inversion HU13 as [nu HU13'].
    assert (stpn false G3 TL3 TL1 G1) as HL31. {
      exists (S (n6+n3)).
      apply stp_transf with (G2:=G2) (T2:=TL2);
      assumption.
    }
    inversion HL31 as [nl HL31'].
    exists (S (n1+n5+nl+nu)).
    apply sdc_typ; assumption.

  + inversion H11.

  + (* sdc_typ - sdc_typu *)
    inversions H12.
    assert (stpn true G1 TU1 TU3 G3) as HU13. {
     eapply trans_le in IHn_stp; [
        eapply IHn_stp; eassumption |
        omega
      ].
    }
    inversion HU13 as [nu HU13'].
    exists (S (n1+nu)).
    apply sdc_typu; assumption.

  + inversion H12.

  + inversion H11.

  + (* sdc_tyu - sdc_tyu *)
    inversions H8.
    assert (stpn true G1 TU1 TU3 G3) as HU13. {
     eapply trans_le in IHn_stp; [
        eapply IHn_stp; eassumption |
        omega
      ].
    }
    inversion HU13 as [nu HU13'].
    exists (S nu).
    apply sdc_tyu; assumption.

  + inversion H9.

  + inversion H9.

  + inversion H12.

  + (* sdc_typu - sdc_tyu *)
    inversions H9.
    assert (stpn true G1 TU1 TU3 G3) as HU13. {
     eapply trans_le in IHn_stp; [
        eapply IHn_stp; eassumption |
        omega
      ].
    }
    inversion HU13 as [nu HU13'].
    exists (S (n1+nu)).
    apply sdc_typu; assumption.

  + inversion H10.

  + inversion H10.

  + inversion H12.

  + inversion H9.

  + inversion H10.

  + (* sdc_mtd - sdc_mtd *)
    inversions H10.
    assert (stpn true G1 TU1 TU3 G3) as HU13. {
     eapply trans_le in IHn_stp; [
        eapply IHn_stp; eassumption |
        omega
      ].
    }
    inversion HU13 as [nu HU13'].
    assert (stpn false G3 TL3 TL1 G1) as HL31. {
      exists (S (n0+n1)).
      apply stp_transf with (G2:=G2) (T2:=TL2);
      assumption.
    }
    inversion HL31 as [nl HL31'].
    exists (S (nl+nu)).
    apply sdc_mtd; assumption.

  + (* sdcs_nil - sdcs_nil *)
    exists (S 0). apply sdcs_nil. assumption.

  + (* sdcs_nil - sdcs_cons -- Ds1 <: [] <: D3::Ds3 *)
    inversion H5. (* decs_has [] D1 *)

  + (* sdcs_cons - sdcs_nil -- Ds1 <: Ds2 <: [] *)
    exists (S 0). apply sdcs_nil.
    eapply sdcs_reg1. apply HS12.

  + (* sdcs_cons - sdcs_cons -- Ds1 <: D2::Ds2 <: D3::Ds3 *)
    (* tricky because D2 and D3 might not have same label *)
    admit.

Qed.

Definition stp_trans n := proj1 (sub_trans n).

Theorem trans: forall G1 T1 G2 T2 G3 T3,
  stpn true G1 T1 T2 G2 ->
  stpn true G2 T2 T3 G3 ->
  stpn true G1 T1 T3 G3.
Proof.
  introv H12 H23.
  destruct H12 as [n12 H12'].
  destruct H23 as [n23 H23'].
  eapply stp_trans with (n:=n12+n23) (n12:=n12) (n23:=n23).
  omega.
  eassumption.
  assumption.
Qed.

(* ###################################################################### *)
(** ** Inversion Lemmas *)

Lemma invert_tc_var: forall G x T,
  tc_trm G (trm_var (avar_f x)) T ->
  exists Gx Tx, binds x (typ_clo Gx Tx) G /\ stpn true Gx Tx T G.
Proof.
  intros G x T H.
  remember (trm_var (avar_f x)) as t.
  induction H; inversion Heqt; subst.
  + exists Gx Tx. split; assumption.
  + specialize (IHtc_trm H1). inversion IHtc_trm as [Gx [Tx [IHb IHstp]]].
    exists Gx Tx. split.
    - assumption.
    - apply trans with (G2:=G) (T2:=T); assumption.
Qed.

(* ###################################################################### *)
(** ** Preservation Lemmas *)

Lemma binds_preserved: forall H G x v CT,
  tc_ctx H G ->
  binds x CT G ->
  binds x v H ->
  tc_val v CT.
Proof.
  intros H G x v CT H_HG H_G H_H.
  induction H_HG.
  - unfold binds in H_G. rewrite get_empty in H_G. inversion H_G.
  - unfold binds in H_G. rewrite get_push in H_G.
    unfold binds in H_H. rewrite get_push in H_H.
    destruct (classicT (x = x0)).
    + inversion H_G. inversion H_H. subst. assumption.
    + unfold binds in IHH_HG. apply IHH_HG; assumption.
Qed.

(* ###################################################################### *)
(** ** Preservation *)

Theorem preservation: forall t H v G T,
  ev H t v ->
  tc_ctx H G ->
  tc_trm G t T ->
  wf_val G v T.
Proof.
  intros t H v G T Hev HG Ht.
  induction Hev.
  + apply invert_tc_var in Ht.
    inversion Ht as [Gx [Tx [IHb IHstp]]].
    apply wf_val_any with (Tv:=Tx) (Gv:=Gx); try assumption.
    apply binds_preserved with (H:=H) (G:=G) (x:=x); assumption.
  + admit.
  + admit.
Qed.


From hahn Require Import Hahn.
From PromisingLib Require Import Basic.
From imm Require Import Events.
From imm Require Import Prog.
From imm Require Import ProgToExecution.

Require Import Basics.
Require Import Events.
Require Import AuxDef.

Module Expr.

Inductive t :=
| val  (v : value)
| reg  (r : Reg.t)
| ereg (e : Event.t)
.

Definition eval (rf : RegFile.t) (erf : Event.t -> value)
           (e : t) : value :=
  match e with
  | val  v => v
  | reg  r => RegFun.find r rf
  | ereg e => erf e
  end.

Definition eval_ereg0 (rf : RegFile.t) (e : t) : value :=
  eval rf (fun _ => 0) e.

Definition used_regs (e : t) : list Reg.t :=
  match e with
  | reg r => [r]
  | _ => nil
  end.

Definition deps_set {A} (df : RegFun.t (A -> Prop)) expr e :=
  exists r,
    << UREG : List.In r (used_regs expr) >> /\
    << INDEPF : df r e >>.

Definition deps_set_alt {A} (df : RegFun.t (A -> Prop)) (e : t) : A -> Prop :=
  match e with
  | reg r => df r
  | _     => ∅
  end.

Lemma deps_set_deps_set_alt {A} (df : RegFun.t (A -> Prop)) e :
  deps_set df e ≡₁ deps_set_alt df e.
Proof.
  unfold deps_set.
  induction e; simpls; basic_solver.
Qed.

Definition used_eregs (e : t) : list Event.t :=
  match e with
  | ereg e => [e]
  | _ => nil
  end.

Definition no_eregs (e : t) : Prop :=
  match e with
  | ereg _ => False
  | _      => True
  end.

Lemma no_eregs_used_eregs (e : t)
      (NOEREGS : no_eregs e) :
  used_eregs e = [].
Proof.
  induction e; auto; simpls.
Qed.

Definition subst_reg (e : t) (r : Reg.t) (e' : t) : t :=
  match e with
  | reg r' => if BinPos.Pos.eqb r r' then e' else e
  | _ => e
  end.

Lemma eval_subst_reg regf eregf e r e' :
  let regf' := fun y =>
                 if BinPos.Pos.eqb r y
                 then eval regf eregf e'
                 else regf y
  in eval regf  eregf (subst_reg e r e') =
     eval regf' eregf e.
Proof.
  induction e; desf.
  unfold subst_reg.
  unfold eval.
  unfold RegFun.find.
  desf; basic_solver.
Qed.

Definition subst_ereg (e : t) (re : Event.t) (e' : t) : t :=
  match e with
  | ereg re' => if Event.eq re re' then e' else e
  | _ => e
  end.

Definition subst_ereg_val_list
           (e : t)
           (l : list (Event.t * value)) : t :=
  List.fold_right
    (fun ev e' => subst_ereg e' (fst ev) (val (snd ev))) e l.

Lemma subst_ereg_val_list_val v l :
  subst_ereg_val_list (val v) l = (val v).
Proof.
  induction l; auto.
  simpl.
  rewrite IHl.
  basic_solver.
Qed.

Lemma no_ereg_subst_ereg m e v
      (NOEREGS: no_eregs m) :
  subst_ereg m e (val v) = m.
Proof.
  induction m; basic_solver.
Qed.

Lemma subst_ereg_no_ereg m e v :
  ~ lset (used_eregs (subst_ereg m e (val v))) e.
Proof.
  induction m; desf; ins.
  desf; ins.
  intro QQ; apply Heq.
  basic_solver.
Qed.

Lemma subst_ereg_val_list_no_eregs m l
      (NOEREGS: no_eregs m) :
  subst_ereg_val_list m l = m.
Proof.
  induction l; auto.
  simpl. rewrite IHl.
  destruct m; ins.
Qed.

Lemma nin_subst_ereg_val_list e l
      (NIN : ~ (lset (List.map fst l)) e) :
  subst_ereg_val_list (ereg e) l = ereg e.
Proof.
  induction l; auto.
  simpls.
  clarify_not.
  rewrite IHl; auto.
  unfold subst_ereg.
  desf; auto.
  basic_solver.
Qed.

Lemma subst_ereg_val_list_ereg e l :
  subst_ereg_val_list (ereg e) l = ereg e
  \/
  exists v',
    In (e, v') l /\
    subst_ereg_val_list (ereg e) l = val v'.
Proof.
  induction l; auto; ins.
  destruct a; ins. desf.
  { rewrite IHl; ins. desf; desf; eauto. }
  rewrite IHl0; ins. eauto.
Qed.

Lemma eval_subst_ereg_val m regf eregf e v :
  let eregf' := fun e' =>
                  if Event.eq e e'
                  then v
                  else eregf e'
  in
  eval regf eregf (subst_ereg m e (val v)) =
  eval regf eregf' m.
Proof.
  induction m; desf.
  unfold subst_ereg.
  unfold eval.
  desf; basic_solver.
Qed.

Lemma used_regs_subst_reg e r m :
  lset (used_regs (subst_reg e r m)) ≡₁
  lset (used_regs e) \₁ eq r ∪₁
  codom_rel ((lset (used_regs e) ∩₁ eq r) × lset (used_regs m)).
Proof.
  induction e; auto; simpls.
  2: { desf; rewrite lset_cons, lset_empty; basic_solver 10. }
  all: basic_solver.
Qed.

Lemma used_eregs_subst_reg e r m :
  lset (used_eregs (subst_reg e r m)) ≡₁
  lset (used_eregs e) ∪₁
  ifP (lset (used_regs e) r) then lset (used_eregs m) else ∅.
Proof.
  induction e; simpls; desf; basic_solver.
Qed.

Lemma nin_subst_reg e r m
      (NO_REG : ~ (lset (used_regs e)) r) :
  subst_reg e r m = e.
Proof.
  induction e; auto; simpls.
  clarify_not.
  desf; basic_solver.
Qed.

Lemma nin_subst_ereg m e v
      (NO_EREG : ~ (lset (used_eregs m)) e) :
  subst_ereg m e v = m.
Proof.
  induction m; auto; simpls.
  clarify_not.
  desf; basic_solver.
Qed.

Lemma compose_subst_ereg_subst_reg expr r e v :
  subst_ereg (subst_reg expr r (ereg e)) e (val v)
  =
  subst_reg (subst_ereg expr e (val v)) r (val v).
Proof.
  induction expr; simpls; eauto.
  { do 2 (desf; simpls). }
  do 2 desf.
Qed.

Lemma subst_reg_same_reg φ r :
  subst_reg φ r (Expr.reg r) = φ.
Proof.
  induction φ; ins; desf; congruence.
Qed.

Lemma subst_ereg_val_idemp m e v v' :
  subst_ereg (subst_ereg m e (val v)) e (val v') =
  subst_ereg m e (val v).
Proof.
  induction m; simpls; eauto.
  desf; basic_solver.
Qed.

Lemma subst_ereg_val_noereg e φ e' v'
      (NO_EREG :  ~ lset (used_eregs φ) e) :
  ~ lset (used_eregs (subst_ereg φ e' (val v'))) e.
Proof.
  induction φ; simpls; eauto.
  desf; basic_solver.
Qed.

Lemma subst_neq_ereg_val_commute φ e v e' v'
      (NEQ : ~ e = e') :
  subst_ereg (subst_ereg φ e (val v)) e' (val v') =
  subst_ereg (subst_ereg φ e' (val v')) e (val v).
Proof.
  induction φ; simpls; eauto.
  desf; basic_solver.
Qed.

Lemma subst_ereg_val_subst_reg_commute m r m' e v
      (NOEREG : ~ lset (used_eregs m') e) :
  subst_ereg (subst_reg m r m') e (val v) =
  subst_reg (subst_ereg m e (val v)) r m'.
Proof.
  destruct m'; auto.
  1-2: by destruct m; basic_solver.
  destruct m; simpls.
  all: by clarify_not; desf; simpl; desf; basic_solver.
Qed.

Lemma compose_subst_ereg_val_list_subst_reg expr r e v l
      (IN : In (e, v) l)
      (FL : func_list l) :
  subst_ereg_val_list (subst_reg expr r (ereg e)) l
  =
  subst_reg (subst_ereg_val_list expr l) r (val v).
Proof.
  induction l; ins.
  destruct (classic (In (e, v) l)) as [AA|AA].
  { rewrite IHl; auto.
    2: now eapply func_list_cons; eauto.
    destruct a; ins.
    now apply subst_ereg_val_subst_reg_commute. }
  desf; ins.
  clear IHl.
  assert (~ lset (map fst l) e) as NLL.
  { intros HH. red in HH. apply in_map_iff in HH. desf.
    enough (x = (fst x, v)) as DD.
    { destruct x; ins. inv DD. }
    apply FL; ins; auto. }
  induction expr; ins.
  { rewrite subst_ereg_val_list_val; ins. }
  { rewrite subst_ereg_val_list_no_eregs with (m:=reg r0); ins.
    desf; desf.
    2: now rewrite subst_ereg_val_list_no_eregs with (m:=reg r0); ins.
    rewrite nin_subst_ereg_val_list; ins. desf; desf. }
  destruct (classic (e0 = e)) as [|NEE]; subst.
  { rewrite nin_subst_ereg_val_list; ins. desf; desf. }
  edestruct subst_ereg_val_list_ereg as [GG|GG].
  { rewrite !GG; ins. desf; desf. }
  desf. rewrite GG0. ins.
Qed.

End Expr.

Section Language.
Local Open Scope program_scope. (* for ∘ *)
(* Definition expression := Value.t. *)

Definition reg_expr := Value.reg.
Definition const_expr := Value.const.

End Language.

Module Stmt.

Inductive t :=
| skip
| assign (r : Reg.t) (m : Expr.t)
| read (r : Reg.t) (L : location) (μ : mode)
| write (L : location) (μ : mode) (m : Expr.t)
| fence (ν : mode)
| ite (m : Expr.t) (s1 s2 : t)
| seq (s1 s2 : t)
| par (s1 s2 : t)
.

Fixpoint used_regs (s : t) : list Reg.t :=
  match s with
  | assign r m     => r :: (Expr.used_regs m)
  | read   r _ _ => [r]
  | write  _ _ m => Expr.used_regs m
  | ite    m s1 s2 => (Expr.used_regs m) ++ used_regs s1 ++ used_regs s2
  | seq      s1 s2 => used_regs s1 ++ used_regs s2
  | par      s1 s2 => used_regs s1 ++ used_regs s2
  | _ => nil
  end.

Fixpoint used_locs (s : t) : list location :=
  match s with
  | read   _ l _ => [l]
  | write  l _ m => [l]
  | ite    m s1 s2 => used_locs s1 ++ used_locs s2
  | seq      s1 s2 => used_locs s1 ++ used_locs s2
  | par      s1 s2 => used_locs s1 ++ used_locs s2
  | _ => nil
  end.

Fixpoint no_eregs (s : t) : Prop :=
  match s with
  | assign r m     => Expr.no_eregs m
  | write  _ _ m => Expr.no_eregs m
  | ite    m s1 s2 => Expr.no_eregs m /\ no_eregs s1 /\ no_eregs s2
  | seq      s1 s2 => no_eregs s1 /\ no_eregs s2
  | par      s1 s2 => no_eregs s1 /\ no_eregs s2
  | _ => True
  end.
End Stmt.

Module Prog.
  Definition t := IdentMap.t Stmt.t.
End Prog.


(** * Common Subexpression Elimination for PHOAS Syntax *)
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.
Require Import Coq.FSets.FMapInterface.
Require Import Crypto.Compilers.Syntax.
Require Import Crypto.Compilers.Equality.
Require Import Crypto.Compilers.CommonSubexpressionElimination.
Require Import Crypto.Util.NatUtil.

Local Open Scope list_scope.

Local Open Scope ctype_scope.
Section symbolic.
  (** Holds decidably-equal versions of raw expressions, for lookup. *)
  Context (base_type_code : Type)
          (op_code : Type)
          (base_type_code_beq : base_type_code -> base_type_code -> bool)
          (op_code_beq : op_code -> op_code -> bool)
          (base_type_code_bl : forall x y, base_type_code_beq x y = true -> x = y)
          (base_type_code_lb : forall x y, x = y -> base_type_code_beq x y = true)
          (op_code_bl : forall x y, op_code_beq x y = true -> x = y)
          (op_code_lb : forall x y, x = y -> op_code_beq x y = true)
          (op : flat_type base_type_code -> flat_type base_type_code -> Type)
          (symbolize_op : forall s d, op s d -> op_code)
          (op_code_leb : op_code -> op_code -> bool)
          (base_type_leb : base_type_code -> base_type_code -> bool)
          (op_code_leb_total : forall x y, op_code_leb x y = true \/ op_code_leb y x = true)
          (base_type_leb_total : forall x y, base_type_leb x y = true \/ base_type_leb y x = true)
          (op_code_leb_antisymmetric : forall x y, op_code_leb x y = true -> op_code_leb y x = true -> op_code_beq x y = true)
          (base_type_leb_antisymmetric : forall x y, base_type_leb x y = true -> base_type_leb y x = true -> base_type_code_beq x y = true).
  Local Notation symbolic_expr := (symbolic_expr base_type_code op_code).
  Context (normalize_symbolic_op_arguments : op_code -> symbolic_expr -> symbolic_expr).

  Local Notation symbolic_expr_beq := (@symbolic_expr_beq base_type_code op_code base_type_code_beq op_code_beq).
  Local Notation symbolic_expr_lb := (@internal_symbolic_expr_dec_lb base_type_code op_code base_type_code_beq op_code_beq base_type_code_lb op_code_lb).
  Local Notation symbolic_expr_bl := (@internal_symbolic_expr_dec_bl base_type_code op_code base_type_code_beq op_code_beq base_type_code_bl op_code_bl).

  Local Notation flat_type := (flat_type base_type_code).
  Local Notation type := (type base_type_code).
  Local Notation exprf := (@exprf base_type_code op).
  Local Notation expr := (@expr base_type_code op).
  Local Notation Expr := (@Expr base_type_code op).

  Local Notation symbolic_expr_leb := (@symbolic_expr_leb base_type_code op_code base_type_code_beq op_code_beq op_code_leb base_type_leb).
  Local Notation flat_type_leb := (@flat_type_leb base_type_code base_type_code_beq base_type_leb).
  Local Notation flat_type_beq := (@flat_type_beq base_type_code base_type_code_beq).
  Local Notation flat_type_bl := (@internal_flat_type_dec_bl base_type_code base_type_code_beq base_type_code_bl).
  Local Notation flat_type_lb := (@internal_flat_type_dec_lb base_type_code base_type_code_beq base_type_code_lb).

  Lemma base_type_leb_reflexive x : base_type_leb x x = true.
  Proof using base_type_leb_total. destruct (base_type_leb_total x x); assumption. Qed.

  Lemma op_code_leb_reflexive x : op_code_leb x x = true.
  Proof using op_code_leb_total. destruct (op_code_leb_total x x); assumption. Qed.

  Theorem flat_type_leb_total : forall a1 a2, flat_type_leb a1 a2 = true \/ flat_type_leb a2 a1 = true.
  Proof using base_type_code_bl base_type_leb_total.
    induction a1, a2;
      repeat first [ progress simpl
                   | progress subst
                   | solve [ auto ]
                   | match goal with
                     | [ H : forall a2', ?leb ?a1 a2' = true \/ _ |- context[?leb ?a1 ?a2] ]
                       => let H' := fresh in destruct (H a2) as [H'|H']; rewrite H'
                     | [ H : flat_type_beq _ _ = true |- _ ] => apply flat_type_bl in H
                     | [ |- context[flat_type_beq ?x ?y] ]
                       => destruct (flat_type_beq x y) eqn:?
                     end ].
  Qed.

  Theorem flat_type_leb_reflexive x : flat_type_leb x x = true.
  Proof using base_type_code_bl base_type_leb_total. destruct (flat_type_leb_total x x); assumption. Qed.

  Local Ltac rewrite_beq_leb_flat_type_op_code_reflexive :=
    repeat match goal with
           | [ H : flat_type_beq _ _ = true |- _ ] => apply flat_type_bl in H
           | [ H : op_code_beq _ _ = true |- _ ] => apply op_code_bl in H
           | [ H : symbolic_expr_beq _ _ = true |- _ ] => apply symbolic_expr_bl in H
           | [ H : context[flat_type_leb ?x ?x] |- _ ]
             => rewrite (flat_type_leb_reflexive x) in H
           | [ |- context[flat_type_leb ?x ?x] ]
             => rewrite (flat_type_leb_reflexive x)
           | [ H : context[flat_type_beq ?x ?x] |- _ ]
             => rewrite (flat_type_lb x x eq_refl) in H
           | [ |- context[flat_type_beq ?x ?x] ]
             => rewrite (flat_type_lb x x eq_refl)
           | [ H : context[op_code_leb ?x ?x] |- _ ]
             => rewrite (op_code_leb_reflexive x) in H
           | [ |- context[op_code_leb ?x ?x] ]
             => rewrite (op_code_leb_reflexive x)
           | [ H : context[op_code_beq ?x ?x] |- _ ]
             => rewrite (op_code_lb x x eq_refl) in H
           | [ |- context[op_code_beq ?x ?x] ]
             => rewrite (op_code_lb x x eq_refl)
           end.

  Theorem flat_type_leb_antisymmetric : forall a1 a2, flat_type_leb a1 a2 = true -> flat_type_leb a2 a1 = true -> flat_type_beq a1 a2 = true.
  Proof using base_type_code_bl base_type_code_lb base_type_leb_antisymmetric base_type_leb_total.
    induction a1, a2;
      repeat first [ progress simpl
                   | progress subst
                   | solve [ auto ]
                   | progress rewrite ?andb_true_r, ?orb_false_r
                   | progress rewrite_beq_leb_flat_type_op_code_reflexive
                   | match goal with
                     | [ |- context[flat_type_beq ?x ?y] ]
                       => destruct (flat_type_beq x y) eqn:?
                     | [ H : forall a2, ?leb ?x a2 = true -> ?leb a2 ?x = true -> _, H0 : ?leb ?x ?a2' = true, H1 : ?leb ?a2' ?x = true |- _ ]
                       => specialize (H _ H0 H1)
                     end
                   | progress intros ].
  Qed.

  Theorem symbolic_expr_leb_total : forall a1 a2, symbolic_expr_leb a1 a2 = true \/ symbolic_expr_leb a2 a1 = true.
  Proof using base_type_code_bl base_type_code_lb base_type_leb_total op_code_bl op_code_lb op_code_leb_total.
    induction a1, a2;
      repeat first [ rewrite !PeanoNat.Nat.leb_le
                   | progress subst
                   | progress simpl
                   | solve [ auto ]
                   | omega
                   | progress rewrite_beq_leb_flat_type_op_code_reflexive
                   | match goal with
                     | [ |- context[flat_type_beq ?x ?y] ]
                       => destruct (flat_type_beq x y) eqn:?
                     | [ |- context[op_code_beq ?x ?y] ]
                       => destruct (op_code_beq x y) eqn:?
                     | [ |- context[symbolic_expr_beq ?x ?y] ]
                       => destruct (symbolic_expr_beq x y) eqn:?
                     | [ H : forall a2', ?leb ?a1 a2' = true \/ _ |- context[?leb ?a1 ?a2] ]
                       => let H' := fresh in destruct (H a2) as [H'|H']; rewrite H'
                     | [ |- context[flat_type_leb ?a1 ?a2] ]
                       => let H' := fresh in destruct (flat_type_leb_total a1 a2) as [H'|H']; rewrite H'
                     | [ |- context[op_code_leb ?a1 ?a2] ]
                       => let H' := fresh in destruct (op_code_leb_total a1 a2) as [H'|H']; rewrite H'
                     end ].
  Qed.

  Theorem symbolic_expr_leb_reflexive x : symbolic_expr_leb x x = true.
  Proof using base_type_code_bl base_type_code_lb base_type_leb_total op_code_bl op_code_lb op_code_leb_total. destruct (symbolic_expr_leb_total x x); assumption. Qed.

  Local Ltac rewrite_beq_leb_symbolic_expr_reflexive :=
    repeat match goal with
           | [ H : symbolic_expr_beq _ _ = true |- _ ] => apply symbolic_expr_bl in H
           | [ H : context[symbolic_expr_leb ?x ?x] |- _ ]
             => rewrite (symbolic_expr_leb_reflexive x) in H
           | [ |- context[symbolic_expr_leb ?x ?x] ]
             => rewrite (symbolic_expr_leb_reflexive x)
           | [ H : context[symbolic_expr_beq ?x ?x] |- _ ]
             => rewrite (symbolic_expr_lb x x eq_refl) in H
           | [ |- context[symbolic_expr_beq ?x ?x] ]
             => rewrite (symbolic_expr_lb x x eq_refl)
           end.

  Theorem symbolic_expr_leb_antisymmetric : forall a1 a2, symbolic_expr_leb a1 a2 = true -> symbolic_expr_leb a2 a1 = true -> symbolic_expr_beq a1 a2 = true.
  Proof using base_type_code_bl base_type_code_lb base_type_leb_antisymmetric base_type_leb_total op_code_bl op_code_lb op_code_leb_antisymmetric op_code_leb_total.
    induction a1, a2;
      repeat first [ rewrite !PeanoNat.Nat.leb_le
                   | progress subst
                   | progress simpl
                   | solve [ auto ]
                   | omega
                   | progress rewrite ?andb_true_r, ?orb_false_r
                   | progress rewrite_beq_leb_flat_type_op_code_reflexive
                   | progress rewrite_beq_leb_symbolic_expr_reflexive
                   | match goal with
                     | [ |- context[flat_type_beq ?x ?y] ]
                       => destruct (flat_type_beq x y) eqn:?
                     | [ |- context[op_code_beq ?x ?y] ]
                       => destruct (op_code_beq x y) eqn:?
                     | [ |- context[symbolic_expr_beq ?x ?y] ]
                       => destruct (symbolic_expr_beq x y) eqn:?
                     | [ |- context[nat_beq ?x ?x] ]
                       => rewrite (internal_nat_dec_lb x x eq_refl)
                     | [ |- context[flat_type_leb ?a1 ?a2] ]
                       => let H' := fresh in destruct (flat_type_leb_total a1 a2) as [H'|H']; rewrite H'
                     | [ |- context[op_code_leb ?a1 ?a2] ]
                       => let H' := fresh in destruct (op_code_leb_total a1 a2) as [H'|H']; rewrite H'
                     | [ H : ?x <= ?y, H' : ?y <= ?x |- _ ] => assert (x = y) by omega; clear H H'
                     | [ H : forall a2, ?leb ?x a2 = true -> ?leb a2 ?x = true -> _, H0 : ?leb ?x ?a2' = true, H1 : ?leb ?a2' ?x = true |- _ ]
                       => specialize (H _ H0 H1)
                     | [ H0 : flat_type_leb ?x' ?y' = true, H1 : flat_type_leb ?y' ?x' = true |- _ ]
                       => pose proof (flat_type_leb_antisymmetric _ _ H0 H1); clear H0 H1
                     | [ H : forall x y, ?leb x y = true -> ?leb y x = true -> _, H0 : ?leb ?x' ?y' = true, H1 : ?leb ?y' ?x' = true |- _ ]
                       => pose proof (H _ _ H0 H1); clear H0 H1
                     end
                   | progress intros ].
  Qed.
End symbolic.


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

(* Why3 assumption *)
Definition unit := unit.

Axiom t : Type.
Parameter t_WhyType : WhyType t.
Existing Instance t_WhyType.

Parameter max: Z.

Parameter to_int: t -> Z.

(* Why3 assumption *)
Definition in_bounds (n:Z): Prop := (0%Z <= n)%Z /\ (n <= max)%Z.

Axiom to_int_in_bounds : forall (n:t), (in_bounds (to_int n)).

Axiom extensionality : forall (x:t) (y:t), ((to_int x) = (to_int y)) ->
  (x = y).

Parameter zero_unsigned: t.

Axiom zero_unsigned_is_zero : ((to_int zero_unsigned) = 0%Z).

Axiom address : Type.
Parameter address_WhyType : WhyType address.
Existing Instance address_WhyType.

Parameter to_int1: address -> Z.

(* Why3 assumption *)
Definition in_bounds1 (n:Z): Prop := (0%Z <= n)%Z /\
  (n <= 1461501637330902918203684832716283019655932542975%Z)%Z.

Axiom to_int_in_bounds1 : forall (n:address), (in_bounds1 (to_int1 n)).

Axiom extensionality1 : forall (x:address) (y:address),
  ((to_int1 x) = (to_int1 y)) -> (x = y).

Parameter zero_unsigned1: address.

Axiom zero_unsigned_is_zero1 : ((to_int1 zero_unsigned1) = 0%Z).

(* Why3 assumption *)
Inductive array (a:Type) :=
  | mk_array : Z -> (map.Map.map Z a) -> array a.
Axiom array_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (array a).
Existing Instance array_WhyType.
Implicit Arguments mk_array [[a]].

(* Why3 assumption *)
Definition elts {a:Type} {a_WT:WhyType a} (v:(array a)): (map.Map.map Z a) :=
  match v with
  | (mk_array x x1) => x1
  end.

(* Why3 assumption *)
Definition length {a:Type} {a_WT:WhyType a} (v:(array a)): Z :=
  match v with
  | (mk_array x x1) => x
  end.

(* Why3 assumption *)
Definition get {a:Type} {a_WT:WhyType a} (a1:(array a)) (i:Z): a :=
  (map.Map.get (elts a1) i).

(* Why3 assumption *)
Definition set {a:Type} {a_WT:WhyType a} (a1:(array a)) (i:Z) (v:a): (array
  a) := (mk_array (length a1) (map.Map.set (elts a1) i v)).

Axiom uint256 : Type.
Parameter uint256_WhyType : WhyType uint256.
Existing Instance uint256_WhyType.

Parameter to_int2: uint256 -> Z.

(* Why3 assumption *)
Definition in_bounds2 (n:Z): Prop := (0%Z <= n)%Z /\
  (n <= 115792089237316195423570985008687907853269984665640564039457584007913129639935%Z)%Z.

Axiom to_int_in_bounds2 : forall (n:uint256), (in_bounds2 (to_int2 n)).

Axiom extensionality2 : forall (x:uint256) (y:uint256),
  ((to_int2 x) = (to_int2 y)) -> (x = y).

Parameter zero_unsigned2: uint256.

Axiom zero_unsigned_is_zero2 : ((to_int2 zero_unsigned2) = 0%Z).

Parameter lookup: (array uint256) -> Z -> Z.

Parameter sum: (array uint256) -> Z -> Z -> Z.

Axiom Sum_def_empty : forall (c:(array uint256)) (i:Z) (j:Z), (j <= i)%Z ->
  ((sum c i j) = 0%Z).

Axiom Sum_def_non_empty : forall (c:(array uint256)) (i:Z) (j:Z),
  (i < j)%Z -> ((sum c i j) = ((lookup c i) + (sum c (i + 1%Z)%Z j))%Z).

Axiom Sum_right_extension : forall (c:(array uint256)) (i:Z) (j:Z),
  (i < j)%Z -> ((sum c i j) = ((sum c i (j - 1%Z)%Z) + (lookup c
  (j - 1%Z)%Z))%Z).

Axiom Sum_transitivity : forall (c:(array uint256)) (i:Z) (k:Z) (j:Z),
  ((i <= k)%Z /\ (k <= j)%Z) -> ((sum c i j) = ((sum c i k) + (sum c k
  j))%Z).

Axiom Sum_eq : forall (c1:(array uint256)) (c2:(array uint256)) (i:Z) (j:Z),
  (forall (k:Z), ((i <= k)%Z /\ (k < j)%Z) -> ((lookup c1 k) = (lookup c2
  k))) -> ((sum c1 i j) = (sum c2 i j)).

(* Why3 goal *)
Theorem blanceSub : forall (uslim:Z) (usorig:(array uint256)) (usidx:Z)
  (usval:uint256) (usnew_val:uint256),
  ((to_int2 usnew_val) = ((to_int2 (get usorig
  usidx)) - (to_int2 usval))%Z) -> (((0%Z <= usidx)%Z /\
  (usidx < uslim)%Z) -> ((sum (set usorig usidx usnew_val) 0%Z
  uslim) = ((sum usorig 0%Z uslim) - (to_int2 usval))%Z)).
(* Why3 intros uslim usorig usidx usval usnew_val h1 (h2,h3). *)
Proof.
  intro uslim.
  case uslim.
  { (* zero *)
    intros ? idx ? ? _.
    omega.
  }
  {
    (* positive *)
    clear uslim.
    induction p using Pos.peano_ind.
    {
      intros orig idx val new_val H.
      intro idx0.
      rewrite Sum_right_extension by (compute; auto).
      simpl.
      Search _ sum.
      rewrite Sum_def_empty by (compute; congruence).
      rewrite Sum_right_extension by (compute; auto).
      simpl.
      rewrite Sum_def_empty by (compute; congruence).
      admit.
    }
    { (* the induction *)
      admit.
    }
  }
  { (* negative *)
    intros ? ? idx ? ? _.
    intro H.
    case H as [H0 H1].
    generalize (Z.le_lt_trans _ _ _ H0 H1).
    set (P := (0 < Z.neg _)%Z).
    compute in P.
    congruence.
  }
Admitted.


(** * The Subject Reduction Property. *)
Require Import base.
Require Import ut_term.
Require Import ut_red.
Require Import ut_env.
Require Import ut_typ.
Require Import List.

Module Type ut_sr_mod  (X:term_sig) (Y:pts_sig X) (TM:ut_term_mod X) (EM:ut_env_mod X TM) (RM: ut_red_mod X TM).
 Include (ut_typ_mod X Y TM EM RM).
  Import TM EM RM.
Open Scope UT_scope.

(** In order to prove SR, we need to be able to talk
about reduction inside a context. *)

Reserved Notation " a →e b " (at level 20).
Reserved Notation " a →→e b "(at level 20).
Reserved Notation " a ≡e b " (at level 20).

(* How to deal with Beta reduction in the context *)
Inductive Beta_env : Env -> Env -> Prop :=
 | Beta_env_hd   : forall A B Γ , A →  B  -> (A::Γ) →e (B::Γ)
 | Beta_env_cons : forall A Γ Γ', Γ →e Γ' -> (A::Γ) →e (A::Γ')
where " E →e F " := (Beta_env E F) : UT_scope.

Inductive Betas_env : Env -> Env -> Prop :=
 | Betas_env_refl  : forall Γ       , Γ →→e Γ
 | Betas_env_Beta  : forall Γ Γ'    , Γ →e Γ'  -> Γ →→e Γ'
 | Betas_env_trans : forall Γ Γ' Γ'', Γ →→e Γ' -> Γ' →→e Γ'' -> Γ →→e Γ''
where " E →→e F" := (Betas_env E F) : UT_scope.

Inductive Betac_env : Env -> Env -> Prop :=
 | Betac_env_Betas : forall Γ Γ'    , Γ →→e Γ' -> Γ ≡e Γ'
 | Betac_env_sym   : forall Γ Γ'    , Γ ≡e  Γ' -> Γ' ≡e Γ
 | Betac_env_trans : forall Γ Γ' Γ'', Γ ≡e  Γ' -> Γ' ≡e Γ'' -> Γ ≡e Γ''
where "E ≡e F" := (Betac_env E F) : UT_scope.

Hint Constructors Beta_env Betas_env Betac_env.

(** Some basic properties of Beta inside context.*)
Lemma Betas_env_nil : forall Γ, nil →→e Γ -> Γ = nil.
intros. remember (@nil Term) as N. revert HeqN.
induction H; intros; subst; try discriminate.
trivial. inversion H. rewrite IHBetas_env1 in *; trivial.
intuition.
Qed.

Lemma Betas_env_nil2 : forall Γ, Γ →→e nil -> Γ = nil.
intros. remember (@nil Term) as N. revert HeqN.
induction H; intros; subst; try discriminate.
trivial. inversion H. rewrite IHBetas_env2 in *; trivial.
intuition.
Qed.

Lemma Betas_env_inv :forall A B Γ Γ', (A::Γ)  →→e ( B::Γ') -> A →→ B /\ Γ →→e Γ'.
intros. remember (A::Γ) as Γ1; remember (B::Γ') as Γ2.
revert A B Γ Γ' HeqΓ1 HeqΓ2. induction H; intros; subst; try discriminate.
injection HeqΓ2; intros; subst; clear HeqΓ2. intuition.
inversion H; subst; clear H.  intuition. intuition.
destruct Γ'. apply Betas_env_nil in H0. discriminate.
destruct (IHBetas_env1 A t Γ0 Γ') as ( ? & ?); trivial. clear IHBetas_env1.
destruct (IHBetas_env2 t B Γ' Γ'0) as ( ? & ?); trivial. clear IHBetas_env2.
eauto.
Qed.

Lemma Betas_env_hd : forall A B Γ , A→→B -> (A::Γ) →→e (B::Γ).
intros.
induction H.
constructor.
constructor; apply Beta_env_hd; trivial.
apply Betas_env_trans with (N::Γ); intuition.
Qed.

Lemma Betas_env_cons : forall A Γ Γ', Γ →→e Γ' -> (A::Γ) →→e (A::Γ').
intros.
induction H.
constructor.
constructor; apply Beta_env_cons; trivial.
apply Betas_env_trans with (A::Γ'); trivial.
Qed.

Lemma Betas_env_comp : forall A B Γ Γ', A→→B -> Γ →→e Γ' -> (A::Γ) →→e (B::Γ').
intros.
apply Betas_env_trans with (A::Γ').
apply Betas_env_cons; trivial.
apply Betas_env_hd; trivial.
Qed.

(** There is two ways to prove SR: either we prove that reduction inside the
context and inside the term "at the same time" is valid, or we first do this
for the context only at first, but we need to weaken a little the hypothesis.
  Here we choose the second solution.*)
(** First step toward full SR: if we do reductions inside the context
  of a valid judgment, and if the resulting context is well-formed,
  then the judgement is still valid with the resulting context. *)
Lemma Beta_env_sound :   forall Γ M T, Γ ⊢ M : T -> forall Γ', Γ' ⊣ -> Γ →e Γ' -> Γ' ⊢ M : T .
induction 1; intros.
(**)
constructor; trivial.
(**)
revert A v H0 H H1.
induction H2; intros. destruct H0 as (AA&  ? & ?). inversion H3; subst; clear H3.
inversion H1; subst; clear H1. inversion H2; subst; clear H2.
apply Cnv with ( B  ↑ 1 ) s. intuition.
constructor. econstructor;apply H1. exists B; intuition.
change !s with !s ↑ 1. apply thinning with s0 ;trivial.
constructor. trivial. exists AA; intuition.
destruct H0 as (AA&  ? & ?).  inversion H3; subst; clear H3.
constructor. trivial. exists A; intuition.
change (S(S n)) with (1+S n). change #(S n) with (#n  ↑ 1).
rewrite <- lift_lift.
inversion H1; subst; clear H1.
apply thinning with s; trivial. apply IHBeta_env. eauto. inversion H; subst; clear H. eauto.
eauto.
(**)
econstructor. apply H. apply IHtyp1; eauto. apply IHtyp2; eauto.
(**)
econstructor. apply H. apply IHtyp1; eauto. apply IHtyp2; eauto. apply IHtyp3; eauto.
(**)
econstructor.  apply IHtyp1; eauto. apply IHtyp2; eauto.
(**)
econstructor. apply H. eapply IHtyp1; eauto. apply IHtyp2; eauto.
Qed.

(** Same with expansion in the context.*)
Lemma Beta_env_sound_up :   forall Γ M T, Γ ⊢ M : T -> forall Γ', Γ' ⊣ -> Γ' →e Γ -> Γ' ⊢ M : T  .
induction 1; intros.
(**)
constructor; trivial.
(**)
revert A v H0 H H1. induction H2; intros. destruct H0 as (AA&  ? & ?). inversion H3; subst; clear H3.
inversion H1; subst; clear H1. inversion H2; subst; clear H2.
apply Cnv with ( A  ↑ 1 ) s. intuition.
constructor. econstructor; apply H1.  exists A; intuition.
change !s with !s ↑ 1. apply thinning with s0 ;trivial.
constructor. trivial. exists AA; intuition.
destruct H0 as (AA&  ? & ?).  inversion H3; subst; clear H3.
constructor. trivial. exists A; intuition.
change (S(S n)) with (1+S n). change #(S n) with (#n  ↑ 1).
rewrite <- lift_lift.
inversion H1; subst; clear H1.
apply thinning with s; trivial. apply IHBeta_env. exists AA; intuition. inversion H; subst; clear H. eauto.
eauto.
(**)
econstructor. apply H. apply IHtyp1; eauto. apply IHtyp2; eauto.
(**)
econstructor. apply H. apply IHtyp1; eauto. apply IHtyp2; eauto. apply IHtyp3; eauto.
(**)
econstructor.  apply IHtyp1; eauto. apply IHtyp2; eauto.
(**)
econstructor. apply H. eapply IHtyp1; eauto. apply IHtyp2; eauto.
Qed.

(** Second Step: reduction in the term.*)
Lemma Beta_sound : forall Γ M T, Γ ⊢ M : T -> forall N, M → N ->  Γ ⊢ N : T.
induction 1; intros.
(*1*)
inversion H1.
(*2*)
inversion H1.
(*3*)
inversion H2; subst; clear H2. econstructor; eauto. econstructor. apply H. intuition.
eapply Beta_env_sound. apply H1. eauto. intuition.
(*4*)
inversion H3; subst; clear H3. eauto.
apply Cnv with ( Π (A'), B) s3. eauto.
econstructor. apply H. eauto.
eapply Beta_env_sound. apply H1. econstructor. eauto. intuition.
eapply Beta_env_sound. apply H2. econstructor. eauto. intuition.
econstructor; eauto.
(*5*)
inversion H1; subst; clear H1.
assert (exists u, Γ ⊢ Π(A),B : !u). apply TypeCorrect in H.
destruct H. destruct H; discriminate. trivial.
destruct H1. apply gen_pi in H1 as (s & t & u & h); decompose [and] h; clear h.
apply gen_la in H  as (u1 & u2 & u3 & D & ? & ? & ? & ? & ?).
apply PiInj in H as (? & ?).
eapply Cnv with (s := t). eapply Betac_subst2. apply Betac_sym. apply H9.
eapply substitution. apply H7. eapply Cnv. apply H. apply H0. apply H6. constructor.
eauto. change !t with (!t  [ ← N] ). eapply substitution. apply H5. apply H0. constructor.
eauto.

econstructor.  eauto. trivial.
assert (exists u, Γ ⊢ Π(A),B : !u). apply TypeCorrect in H.
destruct H. destruct H; discriminate. trivial.
destruct H1. apply gen_pi in H1 as (s & t & u & h); decompose [and] h; clear h.
apply Cnv with (B [← N']) t. apply Betac_subst. auto.
econstructor. apply H. eauto.
change !t with (!t  [ ← N] ). eapply substitution. apply H6. apply H0. constructor.
eauto.
(**)
eauto.
Qed.

(** With both lemmas, we can now prove the full SR.*)
Lemma SubjectRed : forall Γ M T, Γ ⊢ M : T->
  forall N , M →→ N -> Γ ⊢ N : T.
intros. induction H0.
trivial. eapply Beta_sound.
apply H. trivial. intuition.
Qed.

(** Reduction in the type is valid.*)
Lemma Betas_typ_sound : forall Γ M T, Γ ⊢ M : T ->
 forall T', T →→ T' -> Γ ⊢ M : T'.
intros.
assert ((exists s, T = !s )\/ exists s,  Γ ⊢ T : !s ) by ( apply TypeCorrect in H; intuition).
destruct H1 as [[s Hs]|[s Hs]].
rewrite Hs in *. apply Betas_S in H0. rewrite H0; trivial.
apply Cnv with T s; intuition.
apply SubjectRed with T; intuition.
Qed.

(** Wellformation of a context after reduction.*)
Lemma Beta_env_sound2 : forall Γ Γ', Γ ⊣ -> Γ →e Γ' -> Γ' ⊣.
intros. induction H0; intuition.
inversion H; subst; clear H.
econstructor. eapply Beta_sound. apply H2. trivial.
inversion H; subst; clear H.
econstructor. eapply Beta_env_sound. apply H2.  apply IHBeta_env.
eauto. trivial.
Qed.

Lemma Betas_env_sound2 : forall Γ Γ', Γ ⊣ -> Γ →→e Γ' -> Γ' ⊣.
intros.
induction H0; intuition.
eapply Beta_env_sound2. apply H. trivial.
Qed.

Lemma Betas_env_sound :   forall Γ M T, Γ ⊢ M : T-> forall Γ', Γ →→e Γ' -> Γ' ⊢ M : T.
intros.
induction H0; intuition.
eapply Beta_env_sound. apply H. apply Beta_env_sound2 with Γ. apply wf_typ in H. trivial.
trivial. trivial.
Qed.

Lemma Betas_env_sound_up :   forall Γ M T, Γ ⊢ M : T -> forall Γ', Γ' ⊣ -> Γ' →→e Γ -> Γ' ⊢ M : T.
intros. revert M T H H0 .
induction H1; intros.
trivial.
eapply Beta_env_sound_up. apply H0. trivial. trivial.
apply IHBetas_env1. apply IHBetas_env2. trivial. apply Betas_env_sound2 with Γ; trivial.
trivial.
Qed.

(** In its complete form: SubjectReduction. *)
Lemma Subject_Reduction :  forall Γ M T, Γ ⊢ M : T ->
  forall Γ' N T', M →→ N -> Γ →→e Γ' ->  T →→ T' -> Γ' ⊢ N : T'.
intros.
apply Betas_typ_sound with T; intuition.
apply Betas_env_sound with Γ; intuition.
apply SubjectRed with M; intuition.
Qed.

End ut_sr_mod.


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 U Xu Du Bprime Dprime Dprimeprime : Universe, ((wd_ U O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ A O /\ (wd_ B O /\ (wd_ C O /\ (wd_ D O /\ (wd_ U Eprime /\ (wd_ A Eprime /\ (wd_ Xu O /\ (wd_ Dprimeprime O /\ (wd_ Xu A /\ (wd_ Xu Eprime /\ (wd_ D Du /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ O E D /\ (col_ O E U /\ (col_ O Eprime O /\ (col_ O E Xu /\ (col_ O Eprime Du /\ (col_ O Eprime Bprime /\ (col_ O Eprime Dprime /\ col_ O Eprime Dprimeprime))))))))))))))))))))))))) -> col_ A O Xu)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Export String.
Require Export ch2o.abstract_c.frontend.

Local Open Scope string_scope.

Definition decls: list (string * decl) :=
  [("main",
    FunDecl [] (CTFun [] (CTInt (CIntType None CIntRank)))
      (CSComp
        (CSIf (CEConst (CIntType (Some Signed) CIntRank) 1) (CSScope CSSkip)
          (CSScope CSSkip))
        (CSComp
          (CSIf (CEConst (CIntType (Some Signed) CIntRank) 0)
            (CSScope CSSkip) (CSScope CSSkip))
          (CSReturn
            (Some
              (CEBinOp (ArithOp DivOp)
                (CEBinOp (ArithOp DivOp)
                  (CEConst (CIntType (Some Signed) CIntRank) 17)
                  (CEConst (CIntType (Some Signed) CIntRank) 2))
                (CEBinOp (ArithOp DivOp)
                  (CEConst (CIntType (Some Signed) CIntRank) 15)
                  (CEConst (CIntType (Some Signed) CIntRank) 5))))))))].


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl 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 3 of the License, or
  (at your option) any later version.

  VPrl 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 VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export nuprl_props.
Require Export choice.
Require Export cvterm.

Lemma  tequality_mkc_partial_eq {o} :
  forall lib eq T,
  nuprl lib (mkc_partial T) (mkc_partial T) eq
  <=> {eqt : per,  nuprl lib T T eqt
        # (forall a : @CTerm o, eqt a a -> chaltsc lib a)
        # eq_term_equals eq (per_partial_eq lib eqt)}.
Proof.
  introv; split; introv X.
  - invertsn X; subst; try not_univ.
    allunfold @per_partial; exrepnd; spcast; computes_to_value_isvalue.
    allunfold @eq_term_equals; discover.
    allunfold @per_partial_eq. exrepnd.
    exists eqa.
    dands; sp.
  - exrepnd.
    apply CL_partial.
    unfold per_partial.
    exists T T eqt.
    dands; spcast; auto;
    try (apply computes_to_valc_refl; apply iscvalue_mkc_partial).
Qed.

Lemma equality_partial_in_uni {o} :
  forall lib i (T1 T2 : @CTerm o),
  equality lib (mkc_partial T1) (mkc_partial T2) (mkc_uni i)
  <=> (equality lib T1 T2 (mkc_uni i) # (forall t, member lib t T1 -> chaltsc lib t)).
Proof.
  introv; split; intro teq; repnd.

  - destruct teq as [eq n]; repnd.
    inversion n0; subst; try not_univ.
    duniv j h.
    allrw @univi_exists_iff; exrepnd.
    computes_to_value_isvalue; GC.
    rw h0 in n; exrepnd.
    inversion n1; try not_univ.
    allunfold @per_partial; exrepnd; spcast; computes_to_value_isvalue.
    allfold (@nuprli o lib j0).
    dands.
    exists eq.
    dands; auto.
    allrw.
    exists eqa0; auto.
    introv m.
    destruct m as [eqa' m]; repnd.
    allapply @nuprli_implies_nuprl.
    generalize (nuprl_uniquely_valued lib A1 eqa0 eqa'); intro k; repeat (autodimp k hyp).
    apply (nuprl_refl lib A1 A2); auto.
    apply k in m; discover; auto.

  - destruct teq0 as [eq n]; repnd.
    exists eq; dands; auto.
    inversion n0; subst; try not_univ.
    duniv j h.
    allrw @univi_exists_iff; exrepnd.
    computes_to_value_isvalue; GC.
    rw h0 in n; exrepnd.
    allfold (@nuprli o lib j0).
    allrw.
    exists (per_partial_eq lib eqa).
    apply CL_partial.
    exists T1 T2 eqa.
    dands; spcast; auto;
    try (apply computes_to_valc_refl; apply iscvalue_mkc_partial).
    introv m.
    apply teq.
    exists eqa; sp.
    allapply @nuprli_implies_nuprl.
    apply nuprl_refl in n1; auto.
Qed.

(** %\noindent% We first characterize
    the central content of the formation rule for partial types.
    The proof is a straightforward consequence of the definition of
    [per_partial]. Like Crary%\cite{Crary:1998}%, we can form the
    partial type
    [mkc_partial T]
    only if the [T] is a total type.
    A type is a total type if all its members converge to a value.
    [chaltsc] is a lifted version of [hasvalue], i.e.,
    [chaltsc t] asserts [t] converges to a cononical form.

*)

Lemma tequality_mkc_partial {o} :
  forall lib (T1 T2 : @CTerm o),
  tequality lib (mkc_partial T1) (mkc_partial T2)
  <=> (tequality lib T1 T2 # (forall t, member lib t T1 -> chaltsc lib t)).
Proof.
  introv; split; intro teq; repnd.

  - destruct teq as [eq n].
    inversion n; subst; try not_univ.
    allunfold @per_partial; exrepnd; spcast; computes_to_value_isvalue.
    allfold @nuprl.
    dands.
    exists eqa; sp.
    introv m.
    destruct m as [eqa' m]; repnd.
    generalize (nuprl_uniquely_valued lib A1 eqa eqa'); intro k; repeat (autodimp k hyp).
    apply (nuprl_refl lib A1 A2); auto.
    apply k in m; discover; auto.

  - destruct teq0 as [eq n].
    exists (per_partial_eq lib eq).
    apply CL_partial.
    exists T1 T2 eq.
    dands; spcast; auto;
    try (apply computes_to_valc_refl; apply iscvalue_mkc_partial).
    introv m.
    apply teq.
    exists eq; sp.
    apply nuprl_refl in n; auto.
Qed.

(** %\noindent% Now, We characterize when two elements are equal in a
     partial type.
    The proof is a straightforward consequence of the definition of
    [per_partial_eq] that is used in [per_partial].
*)

Lemma equality_in_mkc_partial {o} :
  forall lib (t t' T : @CTerm o),
    equality lib t t' (mkc_partial T)
    <=> (type lib (mkc_partial T)
        # (chaltsc lib t <=> chaltsc lib t')
        # (chaltsc lib t -> equality lib t t' T)).
Proof.
  intros; split; intro e.

  - unfold equality in e; exrepnd.
    inversion e1; subst; try not_univ.
    allunfold @per_partial; exrepnd; spcast; computes_to_value_isvalue.
    allunfold @eq_term_equals; discover.
    allunfold @per_partial_eq. exrepnd.
    dands; auto; [exists eq; sp  |introv Hyp].
    unfold equality.
    exists eqa.
    dands; auto.

  - exrepnd.
    unfold type, tequality in e0; exrepnd.
    apply tequality_mkc_partial_eq in e2. exrepnd.
    exists (per_partial_eq lib eqt); dands; auto.
    + apply CL_partial; unfold per_partial.
      exrepnd. exists T T eqt; sp; spcast;
      try (apply computes_to_valc_refl; apply iscvalue_mkc_partial).
    + unfold per_partial_eq. dands; auto.
      introv Hc.
      apply e in Hc.
      repnud Hc.
      exrepnd.
      apply (nuprl_uniquely_valued lib T _ eqt ) in Hc0;auto.
Qed.

Lemma not_chavaluec_bot {o} : forall lib, @chaltsc o lib mkc_bot -> False.
Proof.
  introv Hsc.
  spcast.
  allunfold @hasvaluec.
  allunfold @mkc_bot.
  allsimpl.
  apply (not_hasvalue_bot lib); auto.
Qed.

Lemma bot_in_partial_type {o} : forall lib (T : @CTerm o),
  type lib (mkc_partial T)
  -> equality lib mkc_bot mkc_bot (mkc_partial T).
Proof.
  introv Ht.
  apply equality_in_mkc_partial.
  dands; auto;[].
  introv Hc.
  provefalse.
  apply (not_chavaluec_bot lib); auto.
Qed.


From FourCerty Require Import Utility.

Import Utility.

Module SourceLang.

Inductive val : Type :=
  | V_Bool (b : bool)
  | V_Int (i : Z).

Notation environment := (partial_map val).

Inductive prim1 : Type :=
  | P_add1
  | P_sub1
  | P_not.

Inductive prim2 : Type :=
  | P_add
  | P_sub
  | P_and
  | P_or
  | P_eq
  | P_lt
  | P_le.

Inductive tm : Type :=
  | Const (v : val)
  | Var (x : string)
  | Prim1 (op : prim1) (t : tm)
  | Prim2 (op : prim2) (t1 : tm) (t2 : tm)
  | App (f : string) (t : tm)
  | If (t1 : tm) (t2 : tm) (t3 : tm)
  | Let (x : string) (t1 : tm) (t2 : tm).

Inductive defn : Type :=
  Defn (f : string) (x : string) (body : tm).

Notation fundefns := (partial_map (string * tm)).

Inductive prg : Type :=
  Prg (funs : list defn) (e : tm).

Fixpoint build_env (xs : list string) (vs : list val) : result environment :=
  match xs, vs with
  | nil,nil => Ok empty
  | x :: xs', v :: vs' =>
      env <- build_env xs' vs';;
      ret (update env x v)
  | _, _ => Err Error
  end.

Definition do_prim1 (op : prim1) (v : val) : result val :=
  match op with
  | P_add1 =>
    match v with
    | V_Int i => Ok (V_Int (i + 1))
    | _ => Err Error
    end
  | P_sub1 =>
    match v with
    | V_Int i => Ok (V_Int (i - 1))
    | _ => Err Error
    end
  | P_not =>
    match v with
    | V_Bool false => Ok (V_Bool true)
    | _ => Ok (V_Bool false)
    end
  end.

Definition do_prim2 (op : prim2) (v1 : val) (v2 : val) : result val :=
  match op with
  | P_add =>
    match v1, v2 with
    | V_Int i1, V_Int i2 => Ok (V_Int (i1 + i2))
    | _, _ => Err Error
    end
  | P_sub =>
    match v1, v2 with
    | V_Int i1, V_Int i2 => Ok (V_Int (i1 - i2))
    | _, _ => Err Error
    end
  | P_and =>
    match v1, v2 with
    | V_Bool b1, V_Bool b2 => Ok (V_Bool (b1 && b2))
    | _, _ => Err Error
    end
  | P_or =>
    match v1, v2 with
    | V_Bool b1, V_Bool b2 => Ok (V_Bool (b1 || b2))
    | _, _ => Err Error
    end
  | P_eq =>
    match v1, v2 with
    | V_Int i1, V_Int i2 => Ok (V_Bool (Z.eqb i1 i2))
    | _, _ => Err Error
    end
  | P_lt =>
    match v1, v2 with
    | V_Int i1, V_Int i2 => Ok (V_Bool (Z.ltb i1 i2))
    | _, _ => Err Error
    end
  | P_le =>
    match v1, v2 with
    | V_Int i1, V_Int i2 => Ok (V_Bool (Z.leb i1 i2))
    | _, _ => Err Error
    end
  end.

Fixpoint extract_funs (funs : list defn) : fundefns :=
  match funs with
  | nil => empty
  | (Defn fn xs t) :: funs' => update (extract_funs funs') fn (xs ,t)
  end.

Definition eval' (funs : fundefns) :=
  fix eval_fuel (f : nat) :=
    fix eval_tm (t : tm) (env : environment) : result val :=
      match t with
      | Const v => Ok v
      | Var x => lookup env x
      | Prim1 op t' =>
          v <- eval_tm t' env;;
          do_prim1 op v
      | Prim2 op t1 t2 =>
          v1 <- eval_tm t1 env;;
          v2 <- eval_tm t2 env;;
          do_prim2 op v1 v2
      | App fn t =>
          v <- eval_tm t env;;
          '(x, t) <- lookup funs fn;;
          match f with
          | O => Err OOF
          | S f' => eval_fuel f' t (update empty x v)
          end
      | If t1 t2 t3 =>
          v1 <- eval_tm t1 env;;
          match v1 with
          | V_Bool false => eval_tm t3 env
          | _ => eval_tm t2 env
          end
      | Let x t1 t2 =>
          v <- eval_tm t1 env;;
          eval_tm t2 (update env x v)
      end.

Definition eval (f : nat) (p : prg) :=
  match p with
  | Prg funs t => eval' (extract_funs funs) f t empty
  end.

End SourceLang.