(* DEC1 language development.
   Paolo Torrini,
   Universite' Lille-1 - CRIStAL-CNRS
*)
(* type uniqueness *)

Require Export Basics.

Require Export EnvLibA.
Require Export RelLibA.

Require Export Coq.Program.Equality.
Require Import Coq.Init.Specif.
Require Import Coq.Arith.PeanoNat.
Require Import Omega.
Require Import Coq.Lists.List.
Require Import Coq.Logic.ProofIrrelevance.

Require Import StaticSemA.
Require Import DynamicSemA.
Require Import TRInductA.
Require Import WeakenA.
Require Import TSoundnessA.
Require Import SReducA.
Require Import DetermA.

Require Import Coq.Logic.EqdepFacts.

Module STyping (IdT: IdModType) <: IdModType.

Definition Id := IdT.Id.
Definition IdEqDec := IdT.IdEqDec.
Definition IdEq := IdT.IdEq.
Definition W := IdT.W.
Definition Loc_PI := IdT.Loc_PI.
Definition BInit := IdT.BInit.
Definition WP := IdT.WP.

Module DetermI := Determ IdT.
Export DetermI.

(******* strong typing properties **************************)

Lemma prmsTyping_aux4 (ftenv: funTC) (tenv: valTC)
        (fenv: funEnv) (env: valEnv) (es: list Exp) (vs: list Value)
        (ts: list VTyp) (s0 s1: W) :
    MatchEnvsT FunTyping fenv ftenv ->
    MatchEnvsT ValueTyping env tenv ->
    PrmsTyping ftenv tenv fenv (PS es) (PT ts) ->
    PrmsClosure fenv env (Conf Prms s0 (PS es))
        (Conf Prms s1 (PS (map Val vs))) ->
    vlsTyping vs ts.
  intros.
  assert (vs = extractPRunValue ftenv tenv fenv (PS es) (PT ts)
                                X1 X env X0 s0).
  eapply (proj2 (PEvalElim ftenv tenv fenv (PS es) (PT ts)
                                X1 X env X0 s0 s1 vs _)).
  rewrite H.
  assert (PrmsTyping emptyE emptyE emptyE
    (PS
       (projT1
          (PrmsEval ftenv tenv fenv (PS es) (PT ts) X1 X env X0 s0)))
    (PT ts)).
  exact (extractPRunTyping ftenv tenv fenv (PS es) (PT ts)
                                X1 X env X0 s0).
  assert (PrmsTyping ftenv tenv fenv
    (PS
       (projT1
          (PrmsEval ftenv tenv fenv (PS es) (PT ts) X1 X env X0 s0)))
    (PT ts)).
  eapply weakenPrmsTyping in X3.
  exact X3.
  constructor.
  auto.
  clear X3.
  simpl in *.
  generalize (extractPRunCons ftenv tenv fenv (PS es)
                              (PT ts) X1 X env X0 s0).
  intros.
  unfold extractPRunEValue in H0.
  rewrite H0 in X4.
  eapply matchListsAux02_T.
  instantiate (1:= map Val vs).
  rewrite <- H.
  constructor.
  auto.
  rewrite <- H in X4.
  exact X4.
  Unshelve.
  auto.
Defined.

(************************************************************************)

Lemma ValueStrongTyping :
  forall (v: Value) (t1: VTyp),
     ValueTyping v t1 ->
  forall t2: VTyp,
    ValueTyping v t2 ->
        t1 = t2.
Proof.
  intros.
  inversion H; subst.
  inversion H0; subst.
  subst T T0.
  rewrite H1 in H3.
  assert (H2 = H4).
  eapply loc_pi.
  subst.
  destruct t1.
  destruct t2.
  simpl in *.
  revert H1.
  revert H0.
  revert v1.
  rewrite <- H3.
  intros.
  assert (v0 = v1).
  eapply loc_pi.
  subst.
  auto.
Defined.

Lemma IdStrongTyping :
  forall (tenv: valTC) (x: Id) (t1: VTyp),
     IdTyping tenv x t1 ->
  forall t2: VTyp,
    IdTyping tenv x t2 ->
        t1 = t2.
Proof.
  intros.
  inversion X; subst.
  inversion X0; subst.
  inversion X1; subst.
  inversion X2; subst.
  rewrite H in H0.
  injection H0.
  auto.
Defined.

Lemma EnvStrongTyping :
  forall (env: valEnv) (tenv1: valTC),
     EnvTyping env tenv1 ->
  forall tenv2: valTC,
    EnvTyping env tenv2 ->
        tenv1 = tenv2.
Proof.
  intros.
  dependent induction env.
  inversion X; subst.
  inversion X0; subst.
  auto.
  inversion X; subst.
  inversion X0; subst.
  assert (ls2 = ls0).
  eapply IHenv.
  auto.
  auto.
  assert (v2 = v3).
  eapply ValueStrongTyping.
  eauto.
  auto.
  rewrite H.
  rewrite H0.
  auto.
Defined.

Definition UniEType :=
  fun (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
      (e: Exp) (t1: VTyp) (k: ExpTyping ftenv tenv fenv e t1) =>
  FEnvTyping fenv ftenv ->
  forall (t2: VTyp) (ftenv0: funTC),
    FEnvTyping fenv ftenv0 ->
    ExpTyping ftenv0 tenv fenv e t2 ->
        t1 = t2.

Definition UniPType :=
  fun (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
      (ps: Prms) (pt1: PTyp) (k: PrmsTyping ftenv tenv fenv ps pt1) =>
    FEnvTyping fenv ftenv ->
    forall (pt2: PTyp) (ftenv0: funTC),
      FEnvTyping fenv ftenv0 ->
      PrmsTyping ftenv0 tenv fenv ps pt2 ->
        pt1 = pt2.

Definition UniQFType :=
  fun (ftenv: funTC) (fenv: funEnv)
      (qf: QFun) (ft1: FTyp) (k: QFunTyping ftenv fenv qf ft1) =>
    FEnvTyping fenv ftenv ->
    forall (ft2: FTyp) (ftenv0: funTC),
    FEnvTyping fenv ftenv0 ->
      QFunTyping ftenv0 fenv qf ft2 ->
        ft1 = ft2.

Definition UniETypeW (ftenv: funTC)
                      (tenv: valTC) (fenv: funEnv)
                      (e: Exp) (t1: VTyp) :=
  ExpTyping ftenv tenv fenv e t1 ->
  FEnvTyping fenv ftenv ->
  forall (t2: VTyp) (ftenv0: funTC),
    FEnvTyping fenv ftenv0 ->
    ExpTyping ftenv0 tenv fenv e t2 ->
        t1 = t2.

Definition UniFTypeS :=
  fun (f: Fun) (ft1: FTyp) (k: FunTyping f ft1) =>
    forall (ft2: FTyp),
      FunTyping f ft2 ->
        ft1 = ft2.

Definition UniFType :=
  fun (f: Fun) (ft: FTyp) (k: FunTyping f ft) =>
   (forall (fps: valTC) (t: VTyp),
    ft = FT fps t ->
    forall (ftenv: funTC) (i: nat) (fenv: funEnv)
           (x: Id) (e0 e1: Exp),
       FEnvTyping fenv ftenv ->
       f = FC fenv fps e0 e1 x i ->
       match i with
       | 0 => UniETypeW ftenv fps fenv e0 t
       | S j => UniETypeW (updateE ftenv x ft) fps
                (updateE fenv x (FC fenv fps e0 e1 x j)) e1 t
       end).

Definition ExpTypingUni_rect :=
  ExpTyping_str_rect UniFType UniQFType UniEType UniPType.

Lemma ExpStrongTyping :
  forall (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
         (e: Exp) (t1: VTyp),
      ExpTyping ftenv tenv fenv e t1 ->
      FEnvTyping fenv ftenv ->
  forall (t2: VTyp) (ftenv0: funTC),
    FEnvTyping fenv ftenv0 ->
    ExpTyping ftenv0 tenv fenv e t2 ->
        t1 = t2.
Proof.
eapply ExpTypingUni_rect.
- (* SLL *)
  unfold Par_SSL, UniEType.
  intros.
  constructor.
- (* SLL *)
  unfold Par_SSL, UniEType.
  intros.
  constructor.
  assumption.
  assumption.
  assumption.
- (* SSA *)
  unfold Par_SSA, UniFType.
  constructor.
- unfold Par_SSA, UniFType.
  intros.
  constructor.
  assumption.
  assumption.
  assumption.
- (* SSB *)
  unfold Par_SSB, Par_SSA, UniFType.
  intros.
  econstructor.
  exact m0.
  exact m1.
  assumption.
  assumption.
  assumption.
  assumption.
  assumption.
  assumption.
- (* Par_F *)
  unfold UniFType, UniETypeW, UniEType.
  intros.
  inversion H0; subst.
  inversion H1; subst.
  intros.
  eapply H.
  auto.
  Focus 2.
  eauto.
  auto.
- (* Par_F *)
  unfold UniFType, UniETypeW, UniEType.
  intros ftenv tenv fenv.
  intros e0 e1 x n t.
  intros K1 K2 K3 HP1 HP2.
  intros fps t0 E3.
  intros ftenv1 i fenv1 x0 e2 e3 K4 E4.
  inversion E3; subst.
  inversion E4; subst.
  intros.
  eapply HP1.
  eapply updateFEnvLemma.
  assumption.
  assumption.
  eassumption.
  assumption.
- (* Par_Q - QF *)
  unfold UniQFType, UniFType, UniEType, UniETypeW.
  intros.
  inversion X1; subst.
  destruct ft as [fps t].
  specialize (H fps t eq_refl).
  inversion k; subst.
  + inversion X2; subst.
    specialize (H ftenv1 0 fenv0 x e0 e1 X3 eq_refl).
    simpl in *.
    assert (t = t0).
    eapply H.
    auto.
    auto.
    Focus 2.
    eassumption.
    auto.
    rewrite H0.
    auto.
  + inversion X2; subst.
    subst ftenv' fenv'.
    subst ftenv'0 fenv'0. (* to compare X5 and X8 *)
    specialize (H ftenv1
                  (S n) fenv0 x e0 e1 X3 eq_refl).
    simpl in *.
    assert (t = t0).
    eapply H.
    auto.
    eapply updateFEnvLemma.
    auto.
    auto.
    Focus 2.
    eauto.
    eapply updateFEnvLemma.
    auto.
    auto.
    rewrite H0.
    auto.

- (* Par_Q - FVar *)
  unfold  UniQFType, UniFType, UniEType, UniETypeW, Par_SSB, Par_SSA.
  intros.
  inversion X; subst.
  clear X.
  clear X3 X4.
  destruct ft as [fps t].
  specialize (H1 fps t eq_refl).
  inversion X2; subst.
  destruct ft2.
  destruct f.

  inversion m; subst.
  inversion X3; subst.

  +
    inversion X; subst.
    rewrite H0 in H4.

(***)
    assert (f0 = FC fenv fps e0 e1 x0 0).
    eapply (envAppendCompare FunTyping ls0 ls8 ls1 ls3).
    eauto.
    eauto.
    eauto.
    auto.
    auto.

    rewrite H5 in *.

    specialize (H1 ftenv).
    specialize (H1 0 fenv x0 e0 e1).
    specialize (H1 X6 eq_refl).
    simpl in *.
    inversion X8; subst.

    assert (t = ret_type).
    eapply H1.
    auto.
    auto.
    Focus 2.
    eauto.
    auto.
    rewrite H5.
    auto.

  + inversion X; subst.
    rewrite H0 in H4.

    assert (f0 = FC fenv fps e0 e1 x0 (S n0)).
    eapply (envAppendCompare FunTyping ls0 ls8 ls1 ls3).
    eauto.
    eauto.
    eauto.
    auto.
    auto.

    rewrite H5 in *.

    specialize (H1 ftenv).
    specialize (H1 (S n0) fenv x0 e0 e1).
    specialize (H1 X6 eq_refl).
    simpl in *.
    inversion X9; subst.

    assert (t = ret_type).
    eapply H1.
    auto.
    eapply updateFEnvLemma.
    auto.
    auto.
    Focus 2.
    eauto.
    subst ftenv'0.
    eapply updateFEnvLemma.
    auto.
    auto.
    rewrite H5.
    auto.

- (* modify *)
  unfold UniEType.
  intros ftenv tenv fenv T1 T2 VT1 VT2 XF q K H0 t ftenv0 H0' X.
  inversion X; subst.
  eapply inj_pair2 in H6.
  eapply inj_pair2 in H6; subst.
  assert (VT4 = VT1).
  eapply loc_pi.
  subst.
  assert (VT5 = VT2).
  eapply loc_pi.
  subst.
  clear XF2.
  reflexivity.
  (* return *)
- unfold UniEType.
  intros.
  inversion X1; subst.
  inversion X2; subst.
  inversion k; subst.
  eapply ValueStrongTyping.
  eauto.
  eauto.
  inversion k; subst.
  eapply IdStrongTyping.
  eauto.
  auto.
(* bindN *)
- unfold UniEType.
  intros.
  inversion X1; subst.
  eapply H0.
  auto.
  Focus 2.
  eauto.
  auto.
(* bindS *)
- unfold UniEType.
  intros.
  inversion X1; subst.
  eapply H0.
  auto.
  Focus 2.
  subst tenv'.
  assert (t1 = t3).
  eapply H.
  auto.
  Focus 2.
  eauto.
  auto.
  rewrite H1.
  eauto.
  auto.
- unfold UniEType.
  intros.
  inversion X1; subst.
  eapply H.
  eapply overrideEnvLemmaT.
  assumption.
  assumption.
  Focus 2.
  assert (tenvP = tenvP0).
  eapply EnvStrongTyping.
  eauto.
  auto.
  rewrite H0.
  eauto.
  eapply overrideEnvLemmaT.
  auto.
  auto.
- unfold UniEType, UniQFType, UniPType.
  intros.
  inversion X1; subst.
  assert (FT fps t = FT fps0 t2).
  eapply H.
  auto.
  eauto.
  auto.
  injection H1.
  auto.
- unfold UniEType.
  intros.
  inversion X1; subst.
  eapply ValueStrongTyping.
  eauto.
  auto.
- unfold UniEType.
  intros.
  inversion X1; subst.
  eapply H0.
  auto.
  Focus 2.
  eauto.
  auto.
- unfold UniEType, Par_SSL, UniPType.
  intros.
  dependent induction X; subst.
  inversion X2; subst.
  inversion X; subst.
  auto.
  destruct pt2.
  destruct ts.
  + inversion X2; subst.
    inversion X3.
  + inversion m; subst.
    inversion X2; subst.
    inversion X5; subst.
    assert (PT bbs = PT ts).
    {*  eapply IHX.
      auto.
      auto.
      Focus 2.
      econstructor.
      eauto.
      auto.
   }
   injection H.
   intro.
   assert (b = v).
   {* eapply p0.
      auto.
      Focus 2.
      eauto.
      auto.
   }
   rewrite H0.
   rewrite H1.
   auto.
Defined.

Definition PrmsTypingUni_rect :=
  PrmsTyping_str_rect UniFType UniQFType UniEType UniPType.

Lemma PrmsStrongTyping :
  forall (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
         (ps: Prms) (pt: PTyp)
         (k: PrmsTyping ftenv tenv fenv ps pt),
         UniPType ftenv tenv fenv ps pt k.
Proof.
eapply PrmsTypingUni_rect.
- (* SLL *)
  unfold Par_SSL, UniEType.
  intros.
  constructor.
- (* SLL *)
  unfold Par_SSL, UniEType.
  intros.
  constructor.
  assumption.
  assumption.
  assumption.
- (* SSA *)
  unfold Par_SSA, UniFType.
  constructor.
- unfold Par_SSA, UniFType.
  intros.
  constructor.
  assumption.
  assumption.
  assumption.
- (* SSB *)
  unfold Par_SSB, Par_SSA, UniFType.
  intros.
  econstructor.
  exact m0.
  exact m1.
  assumption.
  assumption.
  assumption.
  assumption.
  assumption.
  assumption.
- (* Par_F *)
  unfold UniFType, UniETypeW, UniEType.
  intros.
  inversion H0; subst.
  inversion H1; subst.
  intros.
  eapply H.
  auto.
  Focus 2.
  eauto.
  auto.
- (* Par_F *)
  unfold UniFType, UniETypeW, UniEType.
  intros ftenv tenv fenv.
  intros e0 e1 x n t.
  intros K1 K2 K3 HP1 HP2.
  intros fps t0 E3.
  intros ftenv1 i fenv1 x0 e2 e3 K4 E4.
  inversion E3; subst.
  inversion E4; subst.
  intros.
  eapply HP1.
  eapply updateFEnvLemma.
  assumption.
  assumption.
  eassumption.
  assumption.
- (* Par_Q - QF *)
  unfold UniQFType, UniFType, UniEType, UniETypeW.
  intros.
  inversion X1; subst.
  destruct ft as [fps t].
  specialize (H fps t eq_refl).
  inversion k; subst.
  + inversion X2; subst.
    specialize (H ftenv1 0 fenv0 x e0 e1 X3 eq_refl).
    simpl in *.
    assert (t = t0).
    eapply H.
    auto.
    auto.
    Focus 2.
    eassumption.
    auto.
    rewrite H0.
    auto.
  + inversion X2; subst.
    subst ftenv' fenv'.
    subst ftenv'0 fenv'0. (* to compare X5 and X8 *)
    specialize (H ftenv1
                  (S n) fenv0 x e0 e1 X3 eq_refl).
    simpl in *.
    assert (t = t0).
    eapply H.
    auto.
    eapply updateFEnvLemma.
    auto.
    auto.
    Focus 2.
    eauto.
    eapply updateFEnvLemma.
    auto.
    auto.
    rewrite H0.
    auto.

- (* Par_Q - FVar *)
  unfold  UniQFType, UniFType, UniEType, UniETypeW, Par_SSB, Par_SSA.
  intros.
  inversion X; subst.
  clear X.
  clear X3 X4.
  destruct ft as [fps t].
  specialize (H1 fps t eq_refl).
  inversion X2; subst.
  destruct ft2.
  destruct f.

  inversion m; subst.
  inversion X3; subst.

  +
    inversion X; subst.
    rewrite H0 in H4.

(***)
    assert (f0 = FC fenv fps e0 e1 x0 0).
    eapply (envAppendCompare FunTyping ls0 ls8 ls1 ls3).
    eauto.
    eauto.
    eauto.
    auto.
    auto.

    rewrite H5 in *.

    specialize (H1 ftenv).
    specialize (H1 0 fenv x0 e0 e1).
    specialize (H1 X6 eq_refl).
    simpl in *.
    inversion X8; subst.

    assert (t = ret_type).
    eapply H1.
    auto.
    auto.
    Focus 2.
    eauto.
    auto.
    rewrite H5.
    auto.

  + inversion X; subst.
    rewrite H0 in H4.

    assert (f0 = FC fenv fps e0 e1 x0 (S n0)).
    eapply (envAppendCompare FunTyping ls0 ls8 ls1 ls3).
    eauto.
    eauto.
    eauto.
    auto.
    auto.

    rewrite H5 in *.

    specialize (H1 ftenv).
    specialize (H1 (S n0) fenv x0 e0 e1).
    specialize (H1 X6 eq_refl).
    simpl in *.
    inversion X9; subst.

    assert (t = ret_type).
    eapply H1.
    auto.
    eapply updateFEnvLemma.
    auto.
    auto.
    Focus 2.
    eauto.
    subst ftenv'0.
    eapply updateFEnvLemma.
    auto.
    auto.
    rewrite H5.
    auto.

- (* modify *)
  unfold UniEType.
  intros ftenv tenv fenv T1 T2 VT1 VT2 XF q K H0 t ftenv0 H0' X.
  inversion X; subst.
  eapply inj_pair2 in H6.
  eapply inj_pair2 in H6; subst.
  assert (VT4 = VT1).
  eapply loc_pi.
  subst.
  assert (VT5 = VT2).
  eapply loc_pi.
  subst.
  clear XF2.
  reflexivity.
  (* return *)
- unfold UniEType.
  intros.
  inversion X1; subst.
  inversion X2; subst.
  inversion k; subst.
  eapply ValueStrongTyping.
  eauto.
  eauto.
  inversion k; subst.
  eapply IdStrongTyping.
  eauto.
  auto.
(* bindN *)
- unfold UniEType.
  intros.
  inversion X1; subst.
  eapply H0.
  auto.
  Focus 2.
  eauto.
  auto.
(* bindS *)
- unfold UniEType.
  intros.
  inversion X1; subst.
  eapply H0.
  auto.
  Focus 2.
  subst tenv'.
  assert (t1 = t3).
  eapply H.
  auto.
  Focus 2.
  eauto.
  auto.
  rewrite H1.
  eauto.
  auto.
- unfold UniEType.
  intros.
  inversion X1; subst.
  eapply H.
  eapply overrideEnvLemmaT.
  assumption.
  assumption.
  Focus 2.
  assert (tenvP = tenvP0).
  eapply EnvStrongTyping.
  eauto.
  auto.
  rewrite H0.
  eauto.
  eapply overrideEnvLemmaT.
  auto.
  auto.
- unfold UniEType, UniQFType, UniPType.
  intros.
  inversion X1; subst.
  assert (FT fps t = FT fps0 t2).
  eapply H.
  auto.
  eauto.
  auto.
  injection H1.
  auto.
- unfold UniEType.
  intros.
  inversion X1; subst.
  eapply ValueStrongTyping.
  eauto.
  auto.
- unfold UniEType.
  intros.
  inversion X1; subst.
  eapply H0.
  auto.
  Focus 2.
  eauto.
  auto.
- unfold UniEType, Par_SSL, UniPType.
  intros.
  dependent induction X; subst.
  inversion X2; subst.
  inversion X; subst.
  auto.
  destruct pt2.
  destruct ts.
  + inversion X2; subst.
    inversion X3.
  + inversion m; subst.
    inversion X2; subst.
    inversion X5; subst.
    assert (PT bbs = PT ts).
    {*  eapply IHX.
      auto.
      auto.
      Focus 2.
      econstructor.
      eauto.
      auto.
   }
   injection H.
   intro.
   assert (b = v).
   {* eapply p0.
      auto.
      Focus 2.
      eauto.
      auto.
   }
   rewrite H0.
   rewrite H1.
   auto.
Defined.

Definition QFunTypingUni_rect :=
  QFunTyping_str_rect UniFType UniQFType UniEType UniPType.

Lemma QFunStrongTyping :
  forall (ftenv: funTC) (fenv: funEnv)
         (qf: QFun) (ft: FTyp)
         (k: QFunTyping ftenv fenv qf ft),
     UniQFType ftenv fenv qf ft k.
Proof.
eapply QFunTypingUni_rect.
- (* SLL *)
  unfold Par_SSL, UniEType.
  intros.
  constructor.
- (* SLL *)
  unfold Par_SSL, UniEType.
  intros.
  constructor.
  assumption.
  assumption.
  assumption.
- (* SSA *)
  unfold Par_SSA, UniFType.
  constructor.
- unfold Par_SSA, UniFType.
  intros.
  constructor.
  assumption.
  assumption.
  assumption.
- (* SSB *)
  unfold Par_SSB, Par_SSA, UniFType.
  intros.
  econstructor.
  exact m0.
  exact m1.
  assumption.
  assumption.
  assumption.
  assumption.
  assumption.
  assumption.
- (* Par_F *)
  unfold UniFType, UniETypeW, UniEType.
  intros.
  inversion H0; subst.
  inversion H1; subst.
  intros.
  eapply H.
  auto.
  Focus 2.
  eauto.
  auto.
- (* Par_F *)
  unfold UniFType, UniETypeW, UniEType.
  intros ftenv tenv fenv.
  intros e0 e1 x n t.
  intros K1 K2 K3 HP1 HP2.
  intros fps t0 E3.
  intros ftenv1 i fenv1 x0 e2 e3 K4 E4.
  inversion E3; subst.
  inversion E4; subst.
  intros.
  eapply HP1.
  eapply updateFEnvLemma.
  assumption.
  assumption.
  eassumption.
  assumption.
- (* Par_Q - QF *)
  unfold UniQFType, UniFType, UniEType, UniETypeW.
  intros.
  inversion X1; subst.
  destruct ft as [fps t].
  specialize (H fps t eq_refl).
  inversion k; subst.
  + inversion X2; subst.
    specialize (H ftenv1 0 fenv0 x e0 e1 X3 eq_refl).
    simpl in *.
    assert (t = t0).
    eapply H.
    auto.
    auto.
    Focus 2.
    eassumption.
    auto.
    rewrite H0.
    auto.
  + inversion X2; subst.
    subst ftenv' fenv'.
    subst ftenv'0 fenv'0. (* to compare X5 and X8 *)
    specialize (H ftenv1
                  (S n) fenv0 x e0 e1 X3 eq_refl).
    simpl in *.
    assert (t = t0).
    eapply H.
    auto.
    eapply updateFEnvLemma.
    auto.
    auto.
    Focus 2.
    eauto.
    eapply updateFEnvLemma.
    auto.
    auto.
    rewrite H0.
    auto.

- (* Par_Q - FVar *)
  unfold  UniQFType, UniFType, UniEType, UniETypeW, Par_SSB, Par_SSA.
  intros.
  inversion X; subst.
  clear X.
  clear X3 X4.
  destruct ft as [fps t].
  specialize (H1 fps t eq_refl).
  inversion X2; subst.
  destruct ft2.
  destruct f.

  inversion m; subst.
  inversion X3; subst.

  +
    inversion X; subst.
    rewrite H0 in H4.

(***)
    assert (f0 = FC fenv fps e0 e1 x0 0).
    eapply (envAppendCompare FunTyping ls0 ls8 ls1 ls3).
    eauto.
    eauto.
    eauto.
    auto.
    auto.

    rewrite H5 in *.

    specialize (H1 ftenv).
    specialize (H1 0 fenv x0 e0 e1).
    specialize (H1 X6 eq_refl).
    simpl in *.
    inversion X8; subst.

    assert (t = ret_type).
    eapply H1.
    auto.
    auto.
    Focus 2.
    eauto.
    auto.
    rewrite H5.
    auto.

  + inversion X; subst.
    rewrite H0 in H4.

    assert (f0 = FC fenv fps e0 e1 x0 (S n0)).
    eapply (envAppendCompare FunTyping ls0 ls8 ls1 ls3).
    eauto.
    eauto.
    eauto.
    auto.
    auto.

    rewrite H5 in *.

    specialize (H1 ftenv).
    specialize (H1 (S n0) fenv x0 e0 e1).
    specialize (H1 X6 eq_refl).
    simpl in *.
    inversion X9; subst.

    assert (t = ret_type).
    eapply H1.
    auto.
    eapply updateFEnvLemma.
    auto.
    auto.
    Focus 2.
    eauto.
    subst ftenv'0.
    eapply updateFEnvLemma.
    auto.
    auto.
    rewrite H5.
    auto.

- (* modify *)
  unfold UniEType.
  intros ftenv tenv fenv T1 T2 VT1 VT2 XF q K H0 t ftenv0 H0' X.
  inversion X; subst.
  eapply inj_pair2 in H6.
  eapply inj_pair2 in H6; subst.
  assert (VT4 = VT1).
  eapply loc_pi.
  subst.
  assert (VT5 = VT2).
  eapply loc_pi.
  subst.
  clear XF2.
  reflexivity.
  (* return *)
- unfold UniEType.
  intros.
  inversion X1; subst.
  inversion X2; subst.
  inversion k; subst.
  eapply ValueStrongTyping.
  eauto.
  eauto.
  inversion k; subst.
  eapply IdStrongTyping.
  eauto.
  auto.
(* bindN *)
- unfold UniEType.
  intros.
  inversion X1; subst.
  eapply H0.
  auto.
  Focus 2.
  eauto.
  auto.
(* bindS *)
- unfold UniEType.
  intros.
  inversion X1; subst.
  eapply H0.
  auto.
  Focus 2.
  subst tenv'.
  assert (t1 = t3).
  eapply H.
  auto.
  Focus 2.
  eauto.
  auto.
  rewrite H1.
  eauto.
  auto.
- unfold UniEType.
  intros.
  inversion X1; subst.
  eapply H.
  eapply overrideEnvLemmaT.
  assumption.
  assumption.
  Focus 2.
  assert (tenvP = tenvP0).
  eapply EnvStrongTyping.
  eauto.
  auto.
  rewrite H0.
  eauto.
  eapply overrideEnvLemmaT.
  auto.
  auto.
- unfold UniEType, UniQFType, UniPType.
  intros.
  inversion X1; subst.
  assert (FT fps t = FT fps0 t2).
  eapply H.
  auto.
  eauto.
  auto.
  injection H1.
  auto.
- unfold UniEType.
  intros.
  inversion X1; subst.
  eapply ValueStrongTyping.
  eauto.
  auto.
- unfold UniEType.
  intros.
  inversion X1; subst.
  eapply H0.
  auto.
  Focus 2.
  eauto.
  auto.
- unfold UniEType, Par_SSL, UniPType.
  intros.
  dependent induction X; subst.
  inversion X2; subst.
  inversion X; subst.
  auto.
  destruct pt2.
  destruct ts.
  + inversion X2; subst.
    inversion X3.
  + inversion m; subst.
    inversion X2; subst.
    inversion X5; subst.
    assert (PT bbs = PT ts).
    {*  eapply IHX.
      auto.
      auto.
      Focus 2.
      econstructor.
      eauto.
      auto.
   }
   injection H.
   intro.
   assert (b = v).
   {* eapply p0.
      auto.
      Focus 2.
      eauto.
      auto.
   }
   rewrite H0.
   rewrite H1.
   auto.
Defined.

Definition FunTypingUni_rect :=
  FunTyping_str_rect UniFType UniQFType UniEType UniPType.

Lemma FunStrongTyping :
  forall (f: Fun) (ft: FTyp) (k: FunTyping f ft),
    UniFType f ft k.
Proof.
eapply FunTypingUni_rect.
- (* SLL *)
  unfold Par_SSL, UniEType.
  intros.
  constructor.
- (* SLL *)
  unfold Par_SSL, UniEType.
  intros.
  constructor.
  assumption.
  assumption.
  assumption.
- (* SSA *)
  unfold Par_SSA, UniFType.
  constructor.
- unfold Par_SSA, UniFType.
  intros.
  constructor.
  assumption.
  assumption.
  assumption.
- (* SSB *)
  unfold Par_SSB, Par_SSA, UniFType.
  intros.
  econstructor.
  exact m0.
  exact m1.
  assumption.
  assumption.
  assumption.
  assumption.
  assumption.
  assumption.
- (* Par_F *)
  unfold UniFType, UniETypeW, UniEType.
  intros.
  inversion H0; subst.
  inversion H1; subst.
  intros.
  eapply H.
  auto.
  Focus 2.
  eauto.
  auto.
- (* Par_F *)
  unfold UniFType, UniETypeW, UniEType.
  intros ftenv tenv fenv.
  intros e0 e1 x n t.
  intros K1 K2 K3 HP1 HP2.
  intros fps t0 E3.
  intros ftenv1 i fenv1 x0 e2 e3 K4 E4.
  inversion E3; subst.
  inversion E4; subst.
  intros.
  eapply HP1.
  eapply updateFEnvLemma.
  assumption.
  assumption.
  eassumption.
  assumption.
- (* Par_Q - QF *)
  unfold UniQFType, UniFType, UniEType, UniETypeW.
  intros.
  inversion X1; subst.
  destruct ft as [fps t].
  specialize (H fps t eq_refl).
  inversion k; subst.
  + inversion X2; subst.
    specialize (H ftenv1 0 fenv0 x e0 e1 X3 eq_refl).
    simpl in *.
    assert (t = t0).
    eapply H.
    auto.
    auto.
    Focus 2.
    eassumption.
    auto.
    rewrite H0.
    auto.
  + inversion X2; subst.
    subst ftenv' fenv'.
    subst ftenv'0 fenv'0.
    specialize (H ftenv1
                  (S n) fenv0 x e0 e1 X3 eq_refl).
    simpl in *.
    assert (t = t0).
    eapply H.
    auto.
    eapply updateFEnvLemma.
    auto.
    auto.
    Focus 2.
    eauto.
    eapply updateFEnvLemma.
    auto.
    auto.
    rewrite H0.
    auto.

- (* Par_Q - FVar *)
  unfold  UniQFType, UniFType, UniEType, UniETypeW, Par_SSB, Par_SSA.
  intros.
  inversion X; subst.
  clear X.
  clear X3 X4.
  destruct ft as [fps t].
  specialize (H1 fps t eq_refl).
  inversion X2; subst.
  destruct ft2.
  destruct f.

  inversion m; subst.
  inversion X3; subst.

  +
    inversion X; subst.
    rewrite H0 in H4.

(***)
    assert (f0 = FC fenv fps e0 e1 x0 0).
    eapply (envAppendCompare FunTyping ls0 ls8 ls1 ls3).
    eauto.
    eauto.
    eauto.
    auto.
    auto.

    rewrite H5 in *.

    specialize (H1 ftenv).
    specialize (H1 0 fenv x0 e0 e1).
    specialize (H1 X6 eq_refl).
    simpl in *.
    inversion X8; subst.

    assert (t = ret_type).
    eapply H1.
    auto.
    auto.
    Focus 2.
    eauto.
    auto.
    rewrite H5.
    auto.

  + inversion X; subst.
    rewrite H0 in H4.

    assert (f0 = FC fenv fps e0 e1 x0 (S n0)).
    eapply (envAppendCompare FunTyping ls0 ls8 ls1 ls3).
    eauto.
    eauto.
    eauto.
    auto.
    auto.

    rewrite H5 in *.

    specialize (H1 ftenv).
    specialize (H1 (S n0) fenv x0 e0 e1).
    specialize (H1 X6 eq_refl).
    simpl in *.
    inversion X9; subst.

    assert (t = ret_type).
    eapply H1.
    auto.
    eapply updateFEnvLemma.
    auto.
    auto.
    Focus 2.
    eauto.
    subst ftenv'0.
    eapply updateFEnvLemma.
    auto.
    auto.
    rewrite H5.
    auto.

- (* modify *)
  unfold UniEType.
  intros ftenv tenv fenv T1 T2 VT1 VT2 XF q K H0 t ftenv0 H0' X.
  inversion X; subst.
  eapply inj_pair2 in H6.
  eapply inj_pair2 in H6; subst.
  assert (VT4 = VT1).
  eapply loc_pi.
  subst.
  assert (VT5 = VT2).
  eapply loc_pi.
  subst.
  clear XF2.
  reflexivity.
  (* return *)
- unfold UniEType.
  intros.
  inversion X1; subst.
  inversion X2; subst.
  inversion k; subst.
  eapply ValueStrongTyping.
  eauto.
  eauto.
  inversion k; subst.
  eapply IdStrongTyping.
  eauto.
  auto.
(* bindN *)
- unfold UniEType.
  intros.
  inversion X1; subst.
  eapply H0.
  auto.
  Focus 2.
  eauto.
  auto.
(* bindS *)
- unfold UniEType.
  intros.
  inversion X1; subst.
  eapply H0.
  auto.
  Focus 2.
  subst tenv'.
  assert (t1 = t3).
  eapply H.
  auto.
  Focus 2.
  eauto.
  auto.
  rewrite H1.
  eauto.
  auto.
- unfold UniEType.
  intros.
  inversion X1; subst.
  eapply H.
  eapply overrideEnvLemmaT.
  assumption.
  assumption.
  Focus 2.
  assert (tenvP = tenvP0).
  eapply EnvStrongTyping.
  eauto.
  auto.
  rewrite H0.
  eauto.
  eapply overrideEnvLemmaT.
  auto.
  auto.
- unfold UniEType, UniQFType, UniPType.
  intros.
  inversion X1; subst.
  assert (FT fps t = FT fps0 t2).
  eapply H.
  auto.
  eauto.
  auto.
  injection H1.
  auto.
- unfold UniEType.
  intros.
  inversion X1; subst.
  eapply ValueStrongTyping.
  eauto.
  auto.
- unfold UniEType.
  intros.
  inversion X1; subst.
  eapply H0.
  auto.
  Focus 2.
  eauto.
  auto.
- unfold UniEType, Par_SSL, UniPType.
  intros.
  dependent induction X; subst.
  inversion X2; subst.
  inversion X; subst.
  auto.
  destruct pt2.
  destruct ts.
  + inversion X2; subst.
    inversion X3.
  + inversion m; subst.
    inversion X2; subst.
    inversion X5; subst.
    assert (PT bbs = PT ts).
    {*  eapply IHX.
      auto.
      auto.
      Focus 2.
      econstructor.
      eauto.
      auto.
   }
   injection H.
   intro.
   assert (b = v).
   {* eapply p0.
      auto.
      Focus 2.
      eauto.
      auto.
   }
   rewrite H0.
   rewrite H1.
   auto.
Defined.

Lemma UniFTypeLm0 (fenv: funEnv) (tenv0: valTC)
      (e0 e1: Exp) (x: Id) (ft1: FTyp)
      (k: FunTyping (FC fenv tenv0 e0 e1 x 0) ft1) :
  UniFType (FC fenv tenv0 e0 e1 x 0) ft1 k ->
  UniFTypeS (FC fenv tenv0 e0 e1 x 0) ft1 k.
Proof.
  unfold UniFTypeS.
  unfold UniFType, UniFTypeS, UniETypeW.
  intros.
  destruct ft1 as [tenv t].
  destruct ft2.
  specialize (H tenv t eq_refl).
  inversion k; subst.
  inversion X; subst.
  rename prs_type into tenv.
  rename ret_type into t0.
  specialize (H ftenv 0 fenv x e0 e1 X0 eq_refl).
  simpl in *.
  specialize (H X1 X0).
  specialize (H t0 ftenv0 X2 X3).
  assert (t = t0).
  eapply ExpStrongTyping.
  exact X1.
  auto.
  exact X2.
  auto.
  rewrite H0.
  auto.
Defined.

Lemma UniFTypeLm0a (fenv: funEnv) (tenv0: valTC)
      (e0 e1: Exp) (x: Id) (ft1 ft2: FTyp)
      (k: FunTyping (FC fenv tenv0 e0 e1 x 0) ft1) :
  UniFType (FC fenv tenv0 e0 e1 x 0) ft1 k ->
  FunTyping (FC fenv tenv0 e0 e1 x 0) ft2 -> ft1 = ft2.
  intros.
  eapply UniFTypeLm0.
  eauto.
  auto.
Defined.

Lemma UniFTypeLm0b (fenv: funEnv) (tenv0: valTC)
      (e0 e1: Exp) (x: Id) (ft1 ft2: FTyp)
      (k1: FunTyping (FC fenv tenv0 e0 e1 x 0) ft1)
      (k2: FunTyping (FC fenv tenv0 e0 e1 x 0) ft2) : ft1 = ft2.
  intros.
  inversion k1; subst.
  inversion k2; subst.
  assert (t = t0).
  eapply ExpStrongTyping.
  exact X0.
  auto.
  exact X1.
  auto.
  rewrite H.
  auto.
Defined.

Lemma UniFTypeLm1 (fenv: funEnv) (tenv0: valTC)
      (e0 e1: Exp) (x: Id) (ft1: FTyp)
      (k1: FunTyping (FC fenv tenv0 e0 e1 x 1) ft1)
      (k0: FunTyping (FC fenv tenv0 e0 e1 x 0) ft1):
  UniFType (FC fenv tenv0 e0 e1 x 1) ft1 k1 ->
  UniFType (FC fenv tenv0 e0 e1 x 0) ft1 k0.
Proof.
  unfold UniFType.
  intros.
  destruct ft1 as [tenv1 t1].

  inversion H1; subst.
  inversion H0; subst.
  clear H1.
  clear H0.
  unfold UniETypeW in *.

  intros.
  eapply ExpStrongTyping.
  exact X0.
  auto.
  exact X2.
  auto.
Defined.

Lemma UniFTypeLmN (fenv: funEnv) (tenv0: valTC)
      (e0 e1: Exp) (x: Id) (n: nat) (ft1: FTyp)
      (k1: FunTyping (FC fenv tenv0 e0 e1 x (S n)) ft1)
      (k0: FunTyping (FC fenv tenv0 e0 e1 x n) ft1):
  UniFType (FC fenv tenv0 e0 e1 x (S n)) ft1 k1 ->
  UniFType (FC fenv tenv0 e0 e1 x n) ft1 k0.
Proof.
  unfold UniFType.
  intros.
  destruct ft1 as [tenv1 t1].

  inversion H1; subst.
  inversion H0; subst.
  clear H1.
  clear H0.
  unfold UniETypeW in *.

  destruct i.
  intros.
  eapply ExpStrongTyping.
  exact X0.
  auto.
  exact X2.
  auto.

  intros.
  inversion k0; subst.
  subst ftenv' fenv'.
  eapply ExpStrongTyping.
  exact X5.
  eapply updateFEnvLemma.
  auto.
  auto.
  eapply X2.
  auto.
Defined.

Lemma UniFTypeLm1b (fenv: funEnv) (tenv0: valTC)
      (e0 e1: Exp) (x: Id) (ft1 ft2: FTyp)
      (k1: FunTyping (FC fenv tenv0 e0 e1 x 1) ft1)
      (k2: FunTyping (FC fenv tenv0 e0 e1 x 0) ft2) : ft1 = ft2.
  intros.
  inversion k1; subst.
  inversion X1; subst.
  inversion k2; subst.
  subst ftenv' fenv'.
  assert (t = t0).
  eapply ExpStrongTyping.
  exact X3.
  auto.
  exact X4.
  auto.
  rewrite H.
  auto.
Defined.

Lemma UniFTypeLmPb (fenv: funEnv) (tenv0: valTC)
      (e0 e1: Exp) (x: Id) (n: nat) (ft1 ft2: FTyp)
      (k1: FunTyping (FC fenv tenv0 e0 e1 x n) ft1)
      (k2: FunTyping (FC fenv tenv0 e0 e1 x (S n)) ft2) : ft1 = ft2.
Proof.
  intros.
  inversion k1; subst.

  - inversion k2; subst.
    inversion X3; subst.
    assert (t = t0).
    {+ eapply ExpStrongTyping.
       exact X0.
       auto.
       exact X4.
       auto.
    }
    rewrite H.
    auto.

  - inversion k2; subst.
    subst ftenv' fenv' ftenv'0 fenv'0.
    inversion X4; subst.
    subst ftenv' fenv'.
    assert (t = t0).
    {+ eapply ExpStrongTyping.
       exact X0.
       eapply updateFEnvLemma.
       auto.
       auto.
       eapply updateFEnvLemma.
       eauto.
       eauto.
       auto.
    }
    rewrite H.
    auto.
Defined.

Lemma UniFTypeLmNZE1 (fenv: funEnv) (tenv0: valTC)
      (e0 e1: Exp) (x: Id) (ft: FTyp) :
  forall n: nat,
    FunTyping (FC fenv tenv0 e0 e1 x (S n)) ft ->
    sigT (fun ft0 => FunTyping (FC fenv tenv0 e0 e1 x n) ft0).
Proof.
  intros.
  inversion X; subst.
  econstructor.
  eassumption.
Defined.

Lemma UniFTypeLmNZ1 (fenv: funEnv) (tenv0: valTC)
      (e0 e1: Exp) (x: Id) (ft: FTyp) :
  forall n: nat,
    FunTyping (FC fenv tenv0 e0 e1 x (S n)) ft ->
    FunTyping (FC fenv tenv0 e0 e1 x n) ft.
Proof.
  intros.
  generalize X.
  eapply UniFTypeLmNZE1 in X.
  intro.
  destruct X as [ft0 X].
  eapply UniFTypeLmPb with (ft1:=ft0) (ft2:=ft) in X0.
  rewrite <- X0.
  auto.
  auto.
Defined.

Lemma UniFTypeLmNZ (fenv: funEnv) (tenv0: valTC)
      (e0 e1: Exp) (x: Id) (ft: FTyp) :
  forall n: nat,
    FunTyping (FC fenv tenv0 e0 e1 x n) ft ->
    FunTyping (FC fenv tenv0 e0 e1 x 0) ft.
Proof.
  intros.
  induction n.
  auto.
  eapply UniFTypeLmNZ1 in X.
  eapply IHn.
  auto.
Defined.

Lemma UniFTypeLm (f: Fun) (ft1 ft2: FTyp) (k: FunTyping f ft1) :
  UniFType f ft1 k ->
  FunTyping f ft2 -> ft1 = ft2.
Proof.
  destruct f.
  induction n.
  eapply UniFTypeLm0a.
  intros.
  inversion k; subst.
  eapply (IHn X2).
  eapply UniFTypeLmN.
  exact H.
  inversion X; subst.
  auto.
Defined.

Lemma UniqueFunType (f: Fun) (ft1 ft2: FTyp)
      (k1: FunTyping f ft1)
      (k2: FunTyping f ft2) :  ft1 = ft2.
Proof.
  eapply UniFTypeLm with (k:=k1).
  eapply FunStrongTyping.
  eauto.
Defined.

Lemma UniFTypeLmNZ2 (fenv: funEnv) (tenv0: valTC)
      (e0 e1: Exp) (x: Id) (ft: FTyp) :
  forall n: nat,
    sigT (fun ft0 => FunTyping (FC fenv tenv0 e0 e1 x (S n)) ft0) ->
    FunTyping (FC fenv tenv0 e0 e1 x n) ft ->
    FunTyping (FC fenv tenv0 e0 e1 x (S n)) ft.
Proof.
  intros.
  destruct X as [ft0 X].
  generalize X as X1.
  intro.
  eapply UniFTypeLmNZ1 in X.
  eapply UniqueFunType with (ft2 := ft) in X.
  rewrite X in *.
  assumption.
  assumption.
Defined.

Lemma UniqueFEnvType (fenv: funEnv) (ftenv1 ftenv2: funTC)
      (k1: FEnvTyping fenv ftenv1)
      (k2: FEnvTyping fenv ftenv2) :  ftenv1 = ftenv2.
Proof.
  revert k1 k2.
  revert ftenv1 ftenv2.
  induction fenv.
  intros.
  inversion k1; subst.
  inversion k2; subst.
  auto.
  intros.
  inversion k1; subst.
  inversion k2; subst.
  assert (v2 = v3).
  eapply UniqueFunType.
  eauto.
  auto.
  rewrite H.
  assert (ls2 = ls0).
  eapply IHfenv.
  auto.
  auto.
  rewrite H0.
  auto.
Defined.

Lemma UniqueExpType (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
      (e: Exp) (t1 t2: VTyp)
      (k0: FEnvTyping fenv ftenv)
      (k1: ExpTyping ftenv tenv fenv e t1)
      (k2: ExpTyping ftenv tenv fenv e t2) : t1 = t2.
  eapply ExpStrongTyping.
  eauto.
  auto.
  eauto.
  auto.
Defined.

Lemma UniquePrmsType (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
      (ps: Prms) (pt1 pt2: PTyp)
      (k0: FEnvTyping fenv ftenv)
      (k1: PrmsTyping ftenv tenv fenv ps pt1)
      (k2: PrmsTyping ftenv tenv fenv ps pt2) : pt1 = pt2.
  eapply PrmsStrongTyping.
  eauto.
  auto.
  eauto.
  auto.
Defined.

Lemma UniqueQFunType (ftenv: funTC) (fenv: funEnv)
      (qf: QFun) (ft1 ft2: FTyp)
      (k0: FEnvTyping fenv ftenv)
      (k1: QFunTyping ftenv fenv qf ft1)
      (k2: QFunTyping ftenv fenv qf ft2) : ft1 = ft2.
  eapply QFunStrongTyping.
  eauto.
  auto.
  eauto.
  auto.
Defined.

End STyping.


Require Export typing.

Open Scope ECCA_scope.
Theorem weakening {Γ e A}:
  (Γ ⊢ e : A) ->
  forall r Δ,
    Γ =[r]=> Δ ->
    (Δ ⊢ ([r] e) : A).
Proof.
Admitted.

Lemma weakening1 (g: env) (A U B: exp) (x: name):
(g ⊢ A : U) ->
(g & x ~ Assum B ⊢ [^x] A : U) /\ (forall e: exp, (g & x ~ Def e B ⊢ [^x] A : U)).
Proof.
Admitted.

Require Import String.
Open Scope string.

Lemma WF_1:
(⊢ (ctx_empty & "x" ~ Def eBool (eUni (uType 0)))).
Proof. eapply wf_Def; auto.
Qed.

Lemma WF_2:
(⊢(ctx_empty & "x" ~ Def eBool (eUni (uType 0)) & "y" ~ Assum (eId (free "x")))).
Proof. eapply wf_Assum. apply WF_1. apply aT_Var; eauto with contexts.
Qed.

Lemma WF_3:
(⊢((((ctx_empty & "x" ~ Def eBool (eUni (uType 0))
            & "y" ~ Assum (eId (free "x")))
            & "x" ~ Def (eUni uProp) (eUni (uType 0)))))).
Proof. eapply wf_Def. apply WF_2.
  - apply aT_Ax_Type. apply WF_2.
  - apply aT_Ax_Prop. apply WF_2.
Qed.

Lemma typing_is_broken_part_1:
((ctx_empty & "x" ~ Def eBool (eUni (uType 0)) & "y" ~ Assum (eId (free "x"))) ⊢ eId (free "y") : eBool).
Proof.
eapply aT_Conv.
+ apply aT_Var.
  - apply WF_2.
  - left. auto with contexts.
+ apply aT_Bool. eapply wf_Assum.
  - eapply wf_Def.
    * auto.
    * auto.
    * auto.
  - apply aT_Var; eauto with contexts.
+ apply ST_Cong. apply aE_Step with (e:=eBool).
  - apply R_RedR. apply st_ID with (A:= (eUni (uType 0))); auto with contexts.
  - apply R_Reflex.
Qed.

Lemma typing_is_broken_part_2:
(((ctx_empty & "x" ~ Def eBool (eUni (uType 0))
            & "y" ~ Assum (eId (free "x")))
            & "x" ~ Def (eUni uProp) (eUni (uType 0))) ⊢ eId (free "y") : (eUni uProp)).
Proof.
eapply aT_Conv.
+ apply aT_Var. apply WF_3. left. auto with contexts.
+ apply aT_Ax_Prop. apply WF_3.
+ apply ST_Cong. apply aE_Step with (e:=eUni uProp).
  - apply R_RedR. apply st_ID with (A:= (eUni (uType 0))). auto with contexts.
  - apply R_Reflex.
Qed.

(* Conclusion: We need to shift the bodies of ass/defs in the context when we add a new ass/def *)

Lemma WellFormed_implies (g: env) (A: exp):
WellFormed g ->
forall (x: name),
assumes g (free x) A ->
exists U, Types g ([^x]A) U.
Proof.
induction g.
 - intros. inversion H0. inversion H1. inversion H1. inversion H2.
 - intros. inversion H. subst. inversion H0.
   cbn in H1. destruct (closev a (free x)). Admitted.

(* H1.
  + cbn in H1. destruct (bindv (closev x (free x0))).
    * cut (assumes g v A).
      -- intros. cut (exists n, v = free n).
         ** intros. destruct H3. subst. apply IHWellFormed in H2. destruct H2. exists x2. apply weakening1. auto.
      -- auto.
    * inversion H1. subst. exists U. apply weakening1. auto.
  + cbn in H1. destruct (bindv (closev x x0)).
    * cut (assumes g v A).
      -- intros. apply IHWellFormed in H2. destruct H2. exists x1. apply weakening1. auto.
      -- auto.
    * inversion H1. inversion H2.
  - intros. destruct H2.
    + cbn in H2. destruct (bindv (closev x x0)).
      * cut (assumes g v A).
        -- intros. apply IHWellFormed in H3. destruct H3. exists x1. apply weakening1. auto.
        -- auto.
      * inversion H2.
    + cbn in H2. destruct (bindv (closev x x0)).
      * cut (assumes g v A).
        -- intros. apply IHWellFormed in H3. destruct H3. exists x1. apply weakening1. auto.
        -- auto.
      * inversion H2. inversion H3. subst. exists U. apply weakening1. auto.
Qed. *)

Lemma type_well_typed (g: env) (N: exp) (A: exp) :
  (g ⊢ N : A) ->
  (⊢ g) ->
  exists U , Types g A U.
Proof.
  induction 1.
  - exists (eUni (uType 1)). apply aT_Ax_Type. auto.
  - exists (eUni (uType (S (S i)))). apply aT_Ax_Type. auto.
  - intros. Admitted. (*  apply WellFormed_implies. intros. induction H0.
    + subst. destruct H; destruct h.
    + subst. destruct H. cbn in h. destruct (bindv (closev x0 x)).
      * names.
  - exists (eUni (uType 1)). apply aT_Ax_Type. auto.
  - exists (eUni (uType 0)). apply aT_Bool. auto.
  - exists (eUni (uType 0)). apply aT_Bool. auto.
  - apply IHTypes1.
  - exists (eUni (uType 0)). eapply aT_Sig. shelve. shelve.
  - exists (eUni (uType 0)). apply aT_Ax_Prop. shelve.
  - exists (eUni (uType (S i))). apply aT_Ax_Type. shelve.
  - exists (eUni (uProp)). eapply aT_Prod_Prop. shelve. shelve.
  - shelve.
  - shelve.
  - exists U. auto.
  - shelve.
  - shelve.
  - shelve.
Admitted.  *)

Lemma has_type_wf_g (g: env) (N: exp) (A: exp) (x : name):
  Types g N A ->
  WellFormed g ->
  WellFormed (g & x ~ (Def N A)).
Proof.
  intros.  apply type_well_typed in H as H1; auto. destruct H1.
  apply wf_Def with (U := x0); auto.
Qed.


(** * Stlc: The Simply Typed Lambda-Calculus *)

(** The simply typed lambda-calculus (STLC) is a tiny core
    calculus embodying the key concept of _functional abstraction_,
    which shows up in pretty much every real-world programming
    language in s	ome form (functions, procedures, methods, etc.).

    We will follow exactly the same pattern as in the previous chapter
    when formalizing this calculus (syntax, small-step semantics,
    typing rules) and its main properties (progress and preservation).
    The new technical challenges arise from the mechanisms of
    _variable binding_ and _substitution_.  It which will take some
    work to deal with these. *)

Set Warnings "-notation-overridden,-parsing".
From PLF Require Import Maps.
From PLF Require Import Smallstep.
From PLF Require Import Types.

(* ################################################################# *)
(** * Overview *)

(** The STLC is built on some collection of _base types_:
    booleans, numbers, strings, etc.  The exact choice of base types
    doesn't matter much -- the construction of the language and its
    theoretical properties work out the same no matter what we
    choose -- so for the sake of brevity let's take just [Bool] for
    the moment.  At the end of the chapter we'll see how to add more
    base types, and in later chapters we'll enrich the pure STLC with
    other useful constructs like pairs, records, subtyping, and
    mutable state.

    Starting from boolean constants and conditionals, we add three
    things:
        - variables
        - function abstractions
        - application

    This gives us the following collection of abstract syntax
    constructors (written out first in informal BNF notation -- we'll
    formalize it below). *)
(**

       t ::= x                       variable
           | \x:T1.t2                abstraction
           | t1 t2                   application
           | true                    constant true
           | false                   constant false
           | if t1 then t2 else t3   conditional
*)

(** The [\] symbol in a function abstraction [\x:T1.t2] is generally
    written as a Greek letter "lambda" (hence the name of the
    calculus).  The variable [x] is called the _parameter_ to the
    function; the term [t2] is its _body_.  The annotation [:T1]
    specifies the type of arguments that the function can be applied
    to. *)

(** Some examples:

      - [\x:Bool. x]

        The identity function for booleans.

      - [(\x:Bool. x) true]

        The identity function for booleans, applied to the boolean [true].

      - [\x:Bool. if x then false else true]

        The boolean "not" function.

      - [\x:Bool. true]

        The constant function that takes every (boolean) argument to
        [true]. *)
(**
      - [\x:Bool. \y:Bool. x]

        A two-argument function that takes two booleans and returns
        the first one.  (As in Coq, a two-argument function is really
        a one-argument function whose body is also a one-argument
        function.)

      - [(\x:Bool. \y:Bool. x) false true]

        A two-argument function that takes two booleans and returns
        the first one, applied to the booleans [false] and [true].

        As in Coq, application associates to the left -- i.e., this
        expression is parsed as [((\x:Bool. \y:Bool. x) false) true].

      - [\f:Bool->Bool. f (f true)]

        A higher-order function that takes a _function_ [f] (from
        booleans to booleans) as an argument, applies [f] to [true],
        and applies [f] again to the result.

      - [(\f:Bool->Bool. f (f true)) (\x:Bool. false)]

        The same higher-order function, applied to the constantly
        [false] function. *)

(** As the last several examples show, the STLC is a language of
    _higher-order_ functions: we can write down functions that take
    other functions as arguments and/or return other functions as
    results.

    The STLC doesn't provide any primitive syntax for defining _named_
    functions -- all functions are "anonymous."  We'll see in chapter
    [MoreStlc] that it is easy to add named functions to what we've
    got -- indeed, the fundamental naming and binding mechanisms are
    exactly the same.

    The _types_ of the STLC include [Bool], which classifies the
    boolean constants [true] and [false] as well as more complex
    computations that yield booleans, plus _arrow types_ that classify
    functions. *)
(**

      T ::= Bool
          | T1 -> T2

    For example:

      - [\x:Bool. false] has type [Bool->Bool]

      - [\x:Bool. x] has type [Bool->Bool]

      - [(\x:Bool. x) true] has type [Bool]

      - [\x:Bool. \y:Bool. x] has type [Bool->Bool->Bool]
                              (i.e., [Bool -> (Bool->Bool)])

      - [(\x:Bool. \y:Bool. x) false] has type [Bool->Bool]

      - [(\x:Bool. \y:Bool. x) false true] has type [Bool] *)

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

(** We next formalize the syntax of the STLC. *)

Module STLC.

(* ================================================================= *)
(** ** Types *)

Inductive ty : Type :=
  | TBool  : ty
  | TArrow : ty -> ty -> ty.

(* ================================================================= *)
(** ** Terms *)

Inductive tm : Type :=
  | tvar : string -> tm
  | tapp : tm -> tm -> tm
  | tabs : string -> ty -> tm -> tm
  | ttrue : tm
  | tfalse : tm
  | tif : tm -> tm -> tm -> tm.

(** Note that an abstraction [\x:T.t] (formally, [tabs x T t]) is
    always annotated with the type [T] of its parameter, in contrast
    to Coq (and other functional languages like ML, Haskell, etc.),
    which use type inference to fill in missing annotations.  We're
    not considering type inference here. *)

Open Scope string_scope.

(** Some examples... *)

Definition x := "x".
Definition y := "y".
Definition z := "z".

Hint Unfold x.
Hint Unfold y.
Hint Unfold z.

(** [idB = \x:Bool. x] *)

Notation idB :=
  (tabs x TBool (tvar x)).

(** [idBB = \x:Bool->Bool. x] *)

Notation idBB :=
  (tabs x (TArrow TBool TBool) (tvar x)).

(** [idBBBB = \x:(Bool->Bool) -> (Bool->Bool). x] *)

Notation idBBBB :=
  (tabs x (TArrow (TArrow TBool TBool)
                      (TArrow TBool TBool))
    (tvar x)).

(** [k = \x:Bool. \y:Bool. x] *)

Notation k := (tabs x TBool (tabs y TBool (tvar x))).

(** [notB = \x:Bool. if x then false else true] *)

Notation notB := (tabs x TBool (tif (tvar x) tfalse ttrue)).

(** (We write these as [Notation]s rather than [Definition]s to make
    things easier for [auto].) *)

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

(** To define the small-step semantics of STLC terms, we begin,
    as always, by defining the set of values.  Next, we define the
    critical notions of _free variables_ and _substitution_, which are
    used in the reduction rule for application expressions.  And
    finally we give the small-step relation itself. *)

(* ================================================================= *)
(** ** Values *)

(** To define the values of the STLC, we have a few cases to consider.

    First, for the boolean part of the language, the situation is
    clear: [true] and [false] are the only values.  An [if]
    expression is never a value. *)

(** Second, an application is clearly not a value: It represents a
    function being invoked on some argument, which clearly still has
    work left to do. *)

(** Third, for abstractions, we have a choice:

      - We can say that [\x:T. t1] is a value only when [t1] is a
        value -- i.e., only if the function's body has been
        reduced (as much as it can be without knowing what argument it
        is going to be applied to).

      - Or we can say that [\x:T. t1] is always a value, no matter
        whether [t1] is one or not -- in other words, we can say that
        reduction stops at abstractions.

    Our usual way of evaluating expressions in Coq makes the first
    choice -- for example,

         Compute (fun x:bool => 3 + 4)

    yields [fun x:bool => 7].

    Most real-world functional programming languages make the second
    choice -- reduction of a function's body only begins when the
    function is actually applied to an argument.  We also make the
    second choice here. *)

Inductive value : tm -> Prop :=
  | v_abs : forall x T t,
      value (tabs x T t)
  | v_true :
      value ttrue
  | v_false :
      value tfalse.

Hint Constructors value.

(** Finally, we must consider what constitutes a _complete_ program.

    Intuitively, a "complete program" must not refer to any undefined
    variables.  We'll see shortly how to define the _free_ variables
    in a STLC term.  A complete program is _closed_ -- that is, it
    contains no free variables.

    (Conversely, a term with free variables is often called an _open
    term_.)

    Having made the choice not to reduce under abstractions, we don't
    need to worry about whether variables are values, since we'll
    always be reducing programs "from the outside in," and that means
    the [step] relation will always be working with closed terms.  *)

(* ================================================================= *)
(** ** Substitution *)

(** Now we come to the heart of the STLC: the operation of
    substituting one term for a variable in another term.  This
    operation is used below to define the operational semantics of
    function application, where we will need to substitute the
    argument term for the function parameter in the function's body.
    For example, we reduce

       (\x:Bool. if x then true else x) false

    to

       if false then true else false

    by substituting [false] for the parameter [x] in the body of the
    function.

    In general, we need to be able to substitute some given term [s]
    for occurrences of some variable [x] in another term [t].  In
    informal discussions, this is usually written [ [x:=s]t ] and
    pronounced "substitute [x] with [s] in [t]." *)

(** Here are some examples:

      - [[x:=true] (if x then x else false)]
           yields [if true then true else false]

      - [[x:=true] x] yields [true]

      - [[x:=true] (if x then x else y)] yields [if true then true else y]

      - [[x:=true] y] yields [y]

      - [[x:=true] false] yields [false] (vacuous substitution)

      - [[x:=true] (\y:Bool. if y then x else false)]
           yields [\y:Bool. if y then true else false]

      - [[x:=true] (\y:Bool. x)] yields [\y:Bool. true]

      - [[x:=true] (\y:Bool. y)] yields [\y:Bool. y]

      - [[x:=true] (\x:Bool. x)] yields [\x:Bool. x]

    The last example is very important: substituting [x] with [true] in
    [\x:Bool. x] does _not_ yield [\x:Bool. true]!  The reason for
    this is that the [x] in the body of [\x:Bool. x] is _bound_ by the
    abstraction: it is a new, local name that just happens to be
    spelled the same as some global name [x]. *)

(** Here is the definition, informally...

       [x:=s]x               = s
       [x:=s]y               = y                      if x <> y
       [x:=s](\x:T11. t12)   = \x:T11. t12
       [x:=s](\y:T11. t12)   = \y:T11. [x:=s]t12      if x <> y
       [x:=s](t1 t2)         = ([x:=s]t1) ([x:=s]t2)
       [x:=s]true            = true
       [x:=s]false           = false
       [x:=s](if t1 then t2 else t3) =
                       if [x:=s]t1 then [x:=s]t2 else [x:=s]t3
*)

(** ... and formally: *)

Reserved Notation "'[' x ':=' s ']' t" (at level 20).

Fixpoint subst (x:string) (s:tm) (t:tm) : tm :=
  match t with
  | tvar x' =>
      if beq_string x x' then s else t
  | tabs x' T t1 =>
      tabs x' T (if beq_string x x' then t1 else ([x:=s] t1))
  | tapp t1 t2 =>
      tapp ([x:=s] t1) ([x:=s] t2)
  | ttrue =>
      ttrue
  | tfalse =>
      tfalse
  | tif t1 t2 t3 =>
      tif ([x:=s] t1) ([x:=s] t2) ([x:=s] t3)
  end

where "'[' x ':=' s ']' t" := (subst x s t).

(** _Technical note_: Substitution becomes trickier to define if we
    consider the case where [s], the term being substituted for a
    variable in some other term, may itself contain free variables.
    Since we are only interested here in defining the [step] relation
    on _closed_ terms (i.e., terms like [\x:Bool. x] that include
    binders for all of the variables they mention), we can avoid this
    extra complexity here, but it must be dealt with when formalizing
    richer languages. *)

(** For example, using the definition of substitution above to
    substitute the _open_ term [s = \x:Bool. r], where [r] is a _free_
    reference to some global resource, for the variable [z] in the
    term [t = \r:Bool. z], where [r] is a bound variable, we would get
    [\r:Bool. \x:Bool. r], where the free reference to [r] in [s] has
    been "captured" by the binder at the beginning of [t].

    Why would this be bad?  Because it violates the principle that the
    names of bound variables do not matter.  For example, if we rename
    the bound variable in [t], e.g., let [t' = \w:Bool. z], then
    [[x:=s]t'] is [\w:Bool. \x:Bool. r], which does not behave the
    same as [[x:=s]t = \r:Bool. \x:Bool. r].  That is, renaming a
    bound variable changes how [t] behaves under substitution. *)

(** See, for example, [Aydemir 2008] (in Bib.v) for further discussion
    of this issue. *)

(** **** Exercise: 3 stars (substi_correct)  *)
(** The definition that we gave above uses Coq's [Fixpoint] facility
    to define substitution as a _function_.  Suppose, instead, we
    wanted to define substitution as an inductive _relation_ [substi].
    We've begun the definition by providing the [Inductive] header and
    one of the constructors; your job is to fill in the rest of the
    constructors and prove that the relation you've defined coincides
    with the function given above. *)

Inductive substi (s:tm) (x:string) : tm -> tm -> Prop :=
  | s_var1 :
      substi s x (tvar x) s
  | s_var2 : forall y,
      y <> x ->
      substi s x (tvar y) (tvar y)
  | s_tabs1 : forall x' T t1,
      x = x' ->
      substi s x (tabs x' T t1) (tabs x' T t1)
  | s_tabs2 : forall x' T t1 t2,
      x <> x' ->
      substi s x t1 t2 ->
      substi s x (tabs x' T t1) (tabs x' T t2)
  | s_app : forall t1 t2 t1' t2',
      substi s x t1 t1' ->
      substi s x t2 t2' ->
      substi s x (tapp t1 t2) (tapp t1' t2')
  | s_ttrue :
      substi s x ttrue ttrue
  | s_tfalse :
      substi s x tfalse tfalse
  | s_if : forall t1 t2 t3 t1' t2' t3',
      substi s x t1 t1' ->
      substi s x t2 t2' ->
      substi s x t3 t3' ->
      substi s x (tif t1 t2 t3) (tif t1' t2' t3')
.
Hint Constructors substi.

Theorem substi_correct : forall s x t t',
  [x:=s]t = t' <-> substi s x t t'.
Proof. split.
  - generalize dependent t'.
    induction t; intros; simpl in H;
      try (destruct (beq_stringP x0 s0); subst; auto);
      try (rewrite <- H; auto).
  - intros. induction H; try (subst; reflexivity);
      simpl.
    + rewrite <- beq_string_refl. reflexivity.
    + rewrite false_beq_string; auto.
    + rewrite <- beq_string_true_iff in H.
      rewrite H. reflexivity.
    + rewrite false_beq_string; auto.
      subst. auto.
Qed.

(* ================================================================= *)
(** ** Reduction *)

(** The small-step reduction relation for STLC now follows the
    same pattern as the ones we have seen before.  Intuitively, to
    reduce a function application, we first reduce its left-hand
    side (the function) until it becomes an abstraction; then we
    reduce its right-hand side (the argument) until it is also a
    value; and finally we substitute the argument for the bound
    variable in the body of the abstraction.  This last rule, written
    informally as

      (\x:T.t12) v2 ==> [x:=v2]t12

    is traditionally called "beta-reduction". *)

(**
                               value v2
                     ----------------------------                   (ST_AppAbs)
                     (\x:T.t12) v2 ==> [x:=v2]t12

                              t1 ==> t1'
                           ----------------                           (ST_App1)
                           t1 t2 ==> t1' t2

                              value v1
                              t2 ==> t2'
                           ----------------                           (ST_App2)
                           v1 t2 ==> v1 t2'
*)
(** ... plus the usual rules for conditionals:

                    --------------------------------                (ST_IfTrue)
                    (if true then t1 else t2) ==> t1

                    ---------------------------------              (ST_IfFalse)
                    (if false then t1 else t2) ==> t2

                              t1 ==> t1'
         ----------------------------------------------------           (ST_If)
         (if t1 then t2 else t3) ==> (if t1' then t2 else t3)
*)

(** Formally: *)

Reserved Notation "t1 '==>' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T t12 v2,
         value v2 ->
         (tapp (tabs x T t12) v2) ==> [x:=v2]t12
  | ST_App1 : forall t1 t1' t2,
         t1 ==> t1' ->
         tapp t1 t2 ==> tapp t1' t2
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 ==> t2' ->
         tapp v1 t2 ==> tapp v1  t2'
  | ST_IfTrue : forall t1 t2,
      (tif ttrue t1 t2) ==> t1
  | ST_IfFalse : forall t1 t2,
      (tif tfalse t1 t2) ==> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 ==> t1' ->
      (tif t1 t2 t3) ==> (tif t1' t2 t3)

where "t1 '==>' t2" := (step t1 t2).

Hint Constructors step.

Notation multistep := (multi step).
Notation "t1 '==>*' t2" := (multistep t1 t2) (at level 40).

(* ================================================================= *)
(** ** Examples *)

(** Example:

      (\x:Bool->Bool. x) (\x:Bool. x) ==>* \x:Bool. x

    i.e.,

      idBB idB ==>* idB
*)

Lemma step_example1 :
  (tapp idBB idB) ==>* idB.
Proof.
  eapply multi_step.
    apply ST_AppAbs.
    apply v_abs.
  simpl.
  apply multi_refl.  Qed.

(** Example:

      (\x:Bool->Bool. x) ((\x:Bool->Bool. x) (\x:Bool. x))
            ==>* \x:Bool. x

    i.e.,

      (idBB (idBB idB)) ==>* idB.
*)

Lemma step_example2 :
  (tapp idBB (tapp idBB idB)) ==>* idB.
Proof.
  eapply multi_step.
    apply ST_App2. auto.
    apply ST_AppAbs. auto.
  eapply multi_step.
    apply ST_AppAbs. simpl. auto.
  simpl. apply multi_refl.  Qed.

(** Example:

      (\x:Bool->Bool. x)
         (\x:Bool. if x then false else true)
         true
            ==>* false

    i.e.,

       (idBB notB) ttrue ==>* tfalse.
*)

Lemma step_example3 :
  tapp (tapp idBB notB) ttrue ==>* tfalse.
Proof.
  eapply multi_step.
    apply ST_App1. apply ST_AppAbs. auto. simpl.
  eapply multi_step.
    apply ST_AppAbs. auto. simpl.
  eapply multi_step.
    apply ST_IfTrue. apply multi_refl.  Qed.

(** Example:

      (\x:Bool -> Bool. x)
         ((\x:Bool. if x then false else true) true)
            ==>* false

    i.e.,

      idBB (notB ttrue) ==>* tfalse.

    (Note that this term doesn't actually typecheck; even so, we can
    ask how it reduces.)
*)

Lemma step_example4 :
  tapp idBB (tapp notB ttrue) ==>* tfalse.
Proof.
  eapply multi_step.
    apply ST_App2. auto.
    apply ST_AppAbs. auto. simpl.
  eapply multi_step.
    apply ST_App2. auto.
    apply ST_IfTrue.
  eapply multi_step.
    apply ST_AppAbs. auto. simpl.
  apply multi_refl.  Qed.

(** We can use the [normalize] tactic defined in the [Types] chapter
    to simplify these proofs. *)

Lemma step_example1' :
  (tapp idBB idB) ==>* idB.
Proof. normalize.  Qed.

Lemma step_example2' :
  (tapp idBB (tapp idBB idB)) ==>* idB.
Proof. normalize. Qed.

Lemma step_example3' :
  tapp (tapp idBB notB) ttrue ==>* tfalse.
Proof. normalize.  Qed.

Lemma step_example4' :
  tapp idBB (tapp notB ttrue) ==>* tfalse.
Proof. normalize.  Qed.

(** **** Exercise: 2 stars (step_example5)  *)
(** Try to do this one both with and without [normalize]. *)

Lemma step_example5 :
       tapp (tapp idBBBB idBB) idB
  ==>* idB.
Proof. eapply multi_step. apply ST_App1.
  apply ST_AppAbs. auto.
  simpl. eapply multi_step.
  apply ST_AppAbs. auto.
  simpl. apply multi_refl.
Qed.

Lemma step_example5_with_normalize :
       tapp (tapp idBBBB idBB) idB
  ==>* idB.
Proof. normalize. Qed.

(** [] *)

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

(** Next we consider the typing relation of the STLC. *)

(* ================================================================= *)
(** ** Contexts *)

(** _Question_: What is the type of the term "[x y]"?

    _Answer_: It depends on the types of [x] and [y]!

    I.e., in order to assign a type to a term, we need to know
    what assumptions we should make about the types of its free
    variables.

    This leads us to a three-place _typing judgment_, informally
    written [Gamma |- t \in T], where [Gamma] is a
    "typing context" -- a mapping from variables to their types. *)

(** Following the usual notation for partial maps, we could write [Gamma
    & {{x:T}}] for "update the partial function [Gamma] to also map
    [x] to [T]." *)

Definition context := partial_map ty.

(* ================================================================= *)
(** ** Typing Relation *)

(**
                             Gamma x = T
                            --------------                              (T_Var)
                            Gamma |- x \in T

                   Gamma & {{ x --> T11 }} |- t12 \in T12
                   --------------------------------------               (T_Abs)
                     Gamma |- \x:T11.t12 \in T11->T12

                        Gamma |- t1 \in T11->T12
                          Gamma |- t2 \in T11
                        ----------------------                          (T_App)
                         Gamma |- t1 t2 \in T12

                         --------------------                          (T_True)
                         Gamma |- true \in Bool

                        ---------------------                         (T_False)
                        Gamma |- false \in Bool

       Gamma |- t1 \in Bool    Gamma |- t2 \in T    Gamma |- t3 \in T
       --------------------------------------------------------          (T_If)
                  Gamma |- if t1 then t2 else t3 \in T

    We can read the three-place relation [Gamma |- t \in T] as:
    "under the assumptions in Gamma, the term [t] has the type [T]." *)

Reserved Notation "Gamma '|-' t '\in' T" (at level 40).

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      Gamma |- tvar x \in T
  | T_Abs : forall Gamma x T11 T12 t12,
      Gamma & {{x --> T11}} |- t12 \in T12 ->
      Gamma |- tabs x T11 t12 \in TArrow T11 T12
  | T_App : forall T11 T12 Gamma t1 t2,
      Gamma |- t1 \in TArrow T11 T12 ->
      Gamma |- t2 \in T11 ->
      Gamma |- tapp t1 t2 \in T12
  | T_True : forall Gamma,
       Gamma |- ttrue \in TBool
  | T_False : forall Gamma,
       Gamma |- tfalse \in TBool
  | T_If : forall t1 t2 t3 T Gamma,
       Gamma |- t1 \in TBool ->
       Gamma |- t2 \in T ->
       Gamma |- t3 \in T ->
       Gamma |- tif t1 t2 t3 \in T

where "Gamma '|-' t '\in' T" := (has_type Gamma t T).

Hint Constructors has_type.

(* ================================================================= *)
(** ** Examples *)

Example typing_example_1 :
  empty |- tabs x TBool (tvar x) \in TArrow TBool TBool.
Proof.
  apply T_Abs. apply T_Var. reflexivity.  Qed.

(** Note that since we added the [has_type] constructors to the hints
    database, auto can actually solve this one immediately. *)

Example typing_example_1' :
  empty |- tabs x TBool (tvar x) \in TArrow TBool TBool.
Proof. auto.  Qed.

(** Another example:

       empty |- \x:A. \y:A->A. y (y x)
             \in A -> (A->A) -> A.
*)

Example typing_example_2 :
  empty |-
    (tabs x TBool
       (tabs y (TArrow TBool TBool)
          (tapp (tvar y) (tapp (tvar y) (tvar x))))) \in
    (TArrow TBool (TArrow (TArrow TBool TBool) TBool)).
Proof with auto using update_eq.
  apply T_Abs.
  apply T_Abs.
  eapply T_App. apply T_Var...
  eapply T_App. apply T_Var...
  apply T_Var...
Qed.

(** **** Exercise: 2 stars, optional (typing_example_2_full)  *)
(** Prove the same result without using [auto], [eauto], or
    [eapply] (or [...]). *)

Example typing_example_2_full :
  empty |-
    (tabs x TBool
       (tabs y (TArrow TBool TBool)
          (tapp (tvar y) (tapp (tvar y) (tvar x))))) \in
    (TArrow TBool (TArrow (TArrow TBool TBool) TBool)).
Proof. apply T_Abs.
  apply T_Abs.
  apply T_App with TBool.
  apply T_Var. reflexivity.
  apply T_App with TBool.
  apply T_Var. reflexivity.
  apply T_Var. reflexivity.
Qed.

(** [] *)

(** **** Exercise: 2 stars (typing_example_3)  *)
(** Formally prove the following typing derivation holds: *)
(**
       empty |- \x:Bool->B. \y:Bool->Bool. \z:Bool.
                   y (x z)
             \in T.
*)

Example typing_example_3 :
  exists T,
    empty |-
      (tabs x (TArrow TBool TBool)
         (tabs y (TArrow TBool TBool)
            (tabs z TBool
               (tapp (tvar y) (tapp (tvar x) (tvar z)))))) \in
      T.
Proof with auto using update_eq.
  exists (TArrow (TArrow TBool TBool)
  (TArrow (TArrow TBool TBool) (TArrow TBool TBool))).
  apply T_Abs.
  apply T_Abs.
  apply T_Abs.
  eapply T_App. apply T_Var. reflexivity.
  eapply T_App; apply T_Var; reflexivity.
Qed.

(** [] *)

(** We can also show that terms are _not_ typable.  For example, let's
    formally check that there is no typing derivation assigning a type
    to the term [\x:Bool. \y:Bool, x y] -- i.e.,

    ~ exists T,
        empty |- \x:Bool. \y:Bool, x y \in T.
*)

Example typing_nonexample_1 :
  ~ exists T,
      empty |-
        (tabs x TBool
            (tabs y TBool
               (tapp (tvar x) (tvar y)))) \in
        T.
Proof.
  intros Hc. inversion Hc.
  (* The [clear] tactic is useful here for tidying away bits of
     the context that we're not going to need again. *)
  inversion H. subst. clear H.
  inversion H5. subst. clear H5.
  inversion H4. subst. clear H4.
  inversion H2. subst. clear H2.
  inversion H1. Qed.

(** **** Exercise: 3 stars, optional (typing_nonexample_3)  *)
(** Another nonexample:

    ~ (exists S, exists T,
          empty |- \x:S. x x \in T).
*)

Example typing_nonexample_3 :
  ~ (exists S, exists T,
        empty |-
          (tabs x S
             (tapp (tvar x) (tvar x))) \in
          T).
Proof. intro. inversion H.
  inversion H0.
  inversion H1. subst.
  inversion H7. subst.
  inversion H5. subst. rewrite update_eq in H4.
  inversion H8. subst. rewrite update_eq in H6.
  rewrite H4 in H6. inversion H6.

  clear H0 H1 H5 H7 H8 H4 H6 H.

  generalize dependent T12.
  induction T11; intros;
  inversion H3; eauto.
Qed.

(** [] *)

End STLC.

(** $Date$ *)


From isla Require Import opsem.

Definition a74 : isla_trace :=
  Smt (DeclareConst 42%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "R0" [] (RegVal_Base (Val_Symbolic 42%Z)) Mk_annot :t:
  Smt (DefineConst 43%Z (Val (Val_Symbolic 42%Z) Mk_annot)) Mk_annot :t:
  Smt (DeclareConst 44%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "R1" [] (RegVal_Base (Val_Symbolic 44%Z)) Mk_annot :t:
  Smt (DefineConst 50%Z (Unop (Bvnot) (Val (Val_Symbolic 44%Z) Mk_annot) Mk_annot)) Mk_annot :t:
  Smt (DefineConst 54%Z (Manyop (Bvmanyarith Bvadd) [Manyop (Bvmanyarith Bvadd) [Unop (ZeroExtend 64%N) (Val (Val_Symbolic 43%Z) Mk_annot) Mk_annot; Unop (ZeroExtend 64%N) (Val (Val_Symbolic 50%Z) Mk_annot) Mk_annot] Mk_annot; Val (Val_Bits (BV 128%N 0x1%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  Smt (DefineConst 59%Z (Unop (Extract 63%N 0%N) (Val (Val_Symbolic 54%Z) Mk_annot) Mk_annot)) Mk_annot :t:
  Smt (DefineConst 72%Z (Manyop Concat [Manyop Concat [Manyop Concat [Manyop (Bvmanyarith Bvor) [Manyop (Bvmanyarith Bvand) [Val (Val_Bits (BV 1%N 0x0%Z)) Mk_annot; Unop (Bvnot) (Val (Val_Bits (BV 1%N 0x1%Z)) Mk_annot) Mk_annot] Mk_annot; Unop (Extract 0%N 0%N) (Binop ((Bvarith Bvlshr)) (Val (Val_Symbolic 59%Z) Mk_annot) (Unop (Extract 63%N 0%N) (Val (Val_Bits (BV 128%N 0x3f%Z)) Mk_annot) Mk_annot) Mk_annot) Mk_annot] Mk_annot; Ite (Binop (Eq) (Val (Val_Symbolic 59%Z) Mk_annot) (Val (Val_Bits (BV 64%N 0x0%Z)) Mk_annot) Mk_annot) (Val (Val_Bits (BV 1%N 0x1%Z)) Mk_annot) (Val (Val_Bits (BV 1%N 0x0%Z)) Mk_annot) Mk_annot] Mk_annot; Ite (Binop (Eq) (Unop (ZeroExtend 64%N) (Val (Val_Symbolic 59%Z) Mk_annot) Mk_annot) (Val (Val_Symbolic 54%Z) Mk_annot) Mk_annot) (Val (Val_Bits (BV 1%N 0x0%Z)) Mk_annot) (Val (Val_Bits (BV 1%N 0x1%Z)) Mk_annot) Mk_annot] Mk_annot; Ite (Binop (Eq) (Unop (SignExtend 64%N) (Val (Val_Symbolic 59%Z) Mk_annot) Mk_annot) (Manyop (Bvmanyarith Bvadd) [Manyop (Bvmanyarith Bvadd) [Unop (SignExtend 64%N) (Val (Val_Symbolic 43%Z) Mk_annot) Mk_annot; Unop (SignExtend 64%N) (Val (Val_Symbolic 50%Z) Mk_annot) Mk_annot] Mk_annot; Val (Val_Bits (BV 128%N 0x1%Z)) Mk_annot] Mk_annot) Mk_annot) (Val (Val_Bits (BV 1%N 0x0%Z)) Mk_annot) (Val (Val_Bits (BV 1%N 0x1%Z)) Mk_annot) Mk_annot] Mk_annot)) Mk_annot :t:
  Smt (DefineConst 74%Z (Unop (Extract 3%N 3%N) (Val (Val_Symbolic 72%Z) Mk_annot) Mk_annot)) Mk_annot :t:
  WriteReg "PSTATE" [Field "N"] (RegVal_Struct [("N", RegVal_Base (Val_Symbolic 74%Z))]) Mk_annot :t:
  Smt (DefineConst 75%Z (Unop (Extract 2%N 2%N) (Val (Val_Symbolic 72%Z) Mk_annot) Mk_annot)) Mk_annot :t:
  WriteReg "PSTATE" [Field "Z"] (RegVal_Struct [("Z", RegVal_Base (Val_Symbolic 75%Z))]) Mk_annot :t:
  Smt (DefineConst 76%Z (Unop (Extract 1%N 1%N) (Val (Val_Symbolic 72%Z) Mk_annot) Mk_annot)) Mk_annot :t:
  WriteReg "PSTATE" [Field "C"] (RegVal_Struct [("C", RegVal_Base (Val_Symbolic 76%Z))]) Mk_annot :t:
  Smt (DefineConst 77%Z (Unop (Extract 0%N 0%N) (Val (Val_Symbolic 72%Z) Mk_annot) Mk_annot)) Mk_annot :t:
  WriteReg "PSTATE" [Field "V"] (RegVal_Struct [("V", RegVal_Base (Val_Symbolic 77%Z))]) Mk_annot :t:
  Smt (DeclareConst 78%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "_PC" [] (RegVal_Base (Val_Symbolic 78%Z)) Mk_annot :t:
  Smt (DefineConst 79%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 78%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "_PC" [] (RegVal_Base (Val_Symbolic 79%Z)) Mk_annot :t:
  tnil
.


Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List.
Require Import Coq.micromega.Lia.
Require Import Coq.Strings.String.
Require Import bedrock2.ProgramLogic.
Require Import bedrock2.Map.Separation.
Require Import bedrock2.Map.SeparationLogic.
Require Import bedrock2.WeakestPreconditionProperties.
Require Import coqutil.Map.Interface.
Require Import coqutil.Word.Interface.
Require Import coqutil.Datatypes.List.
Require Import coqutil.Datatypes.PropSet.
Require Import Crypto.Bedrock.Field.Common.Types.
Require Import Crypto.Bedrock.Field.Common.Tactics.
Require Import Crypto.Bedrock.Field.Common.Util.
Require Import Crypto.Bedrock.Field.Translation.Proofs.Expr.
Require Import Crypto.Bedrock.Field.Translation.Proofs.Equivalence.
Require Import Crypto.Bedrock.Field.Translation.Proofs.EquivalenceProperties.
Require Import Crypto.Bedrock.Field.Translation.Proofs.UsedVarnames.
Require Import Crypto.Bedrock.Field.Translation.Proofs.VarnameSet.
Require Import Crypto.Bedrock.Field.Translation.Cmd.
Require Import Crypto.Bedrock.Field.Translation.Expr.
Require Import Crypto.Language.API.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Util.Notations.
Import ListNotations. Local Open Scope Z_scope.

(* for [eauto with lia] *)
Require Import Crypto.BoundsPipeline.

Import API.Compilers.
Import Wf.Compilers.expr.
Import Types.Notations.

Section Cmd.
  Context
    {width BW word mem locals env ext_spec varname_gen error}
   `{parameters_sentinel : @parameters width BW word mem locals env ext_spec varname_gen error}.
  Context {ok : ok}.

  Local Existing Instance Types.rep.Z.
  Local Existing Instance Types.rep.listZ_local.

  Inductive valid_cmd :
    forall {t}, @API.expr (fun _ => unit) t -> Prop :=
  (* N.B. LetIn is split into cases so that only pairs of type_base and type_base are
      allowed; this is primarily because we don't want lists on the LHS *)
  | valid_LetIn_prod :
      forall {a b c} x f,
        valid_expr true x -> valid_cmd (f tt) ->
        valid_cmd (expr.LetIn
                     (A:=type.base (base.type.prod
                                      (base.type.type_base a) (base.type.type_base b)))
                     (B:=type.base c) x f)
  | valid_LetIn_base :
      forall {a b} x f,
        valid_expr true x -> valid_cmd (f tt) ->
        valid_cmd (expr.LetIn (A:=type.base (base.type.type_base a)) (B:=type.base b) x f)
  | valid_cons :
      forall x l,
        valid_expr true x ->
        valid_cmd l ->
        valid_cmd
          (expr.App
             (expr.App
                (expr.Ident
                   (ident.cons (t:=base.type.type_base base.type.Z))) x) l)
  | valid_nil :
      valid_cmd (expr.Ident (ident.nil (t:=base.type.type_base base.type.Z)))
  | valid_inner :
      forall {t} e,
        valid_expr (t:=type.base t) true e ->
        valid_cmd e
  .

  Lemma assign_list_correct :
    forall (rhs : base_rtype base_listZ)
           (xs : base.interp base_listZ)
           (nextn : nat)
           tr
           (mem : mem)
           (locals : locals)
           functions,
      (* rhs == x *)
      locally_equivalent_base xs rhs locals ->
      (* locals don't contain any variables we can overwrite *)
      (forall n nvars,
          (nextn <= n)%nat ->
          map.undef_on locals (used_varnames (varname_gen:=varname_gen) n nvars)) ->
      let out := assign_list nextn rhs in
      let nvars := fst (fst out) in
      let lhs := snd (fst out) in
      WeakestPrecondition.cmd
        (WeakestPrecondition.call functions)
        (snd out)
        tr mem locals
        (fun tr' mem' locals' =>
           tr = tr'
           /\ mem = mem'
           /\ PropSet.sameset (varname_set_base lhs)
                              (used_varnames (varname_gen:=varname_gen) nextn nvars)
           /\ map.only_differ locals (varname_set_base lhs) locals'
           /\ locally_equivalent_base xs (base_rtype_of_ltype lhs) locals').
  Proof.
    cbn [locally_equivalent_base equivalent_base rep.equiv rep.listZ_local].
    induction rhs; intros; cbn [assign_list fst snd].
    { repeat straightline.
      repeat match goal with
             | |- _ /\ _ => split
             | _ => eassumption
             | _ => apply only_differ_empty
             | _ => reflexivity
             end. }
    { match goal with
        H : Forall2 _ ?x (_ :: _) |- _ =>
        destruct x; inversion H; subst; clear H; [ ]
      end.
      cbn [rep.equiv rep.Z] in *. sepsimpl.
      repeat straightline.
      eexists; split; [ eapply expr_empty; eassumption | ].
      eapply Proper_cmd; [ solve [apply Proper_call] | repeat intro | ].
      2:{
        eapply IHrhs; eauto.
        { eapply Forall2_impl_strong; eauto.
          intros; sepsimpl; [ lia .. | ].
          eexists; sepsimpl; [ eassumption | ].
          eapply expr_only_differ_undef; eauto.
          rewrite used_varnames_1.
          eauto using @only_differ_sym, @only_differ_put with typeclass_instances. }
        { intros. apply put_undef_on; eauto with lia.
          rewrite used_varnames_iff; intro; cleanup.
          match goal with H : varname_gen _ = varname_gen _ |- _ =>
                          apply varname_gen_unique in H end.
          lia. } }
      cbv beta in *. cleanup; subst.
      repeat match goal with |- _ /\ _ => split end;
        try reflexivity.
      { cbn [varname_set_base
               rep.varname_set rep.listZ_local rep.Z fold_right] in *.
        rewrite used_varnames_succ_low, add_union_singleton.
        match goal with H : PropSet.sameset _ _ |- _ =>
                        rewrite H end.
        reflexivity. }
      { cbn [varname_set_base
               rep.varname_set rep.listZ_local rep.Z fold_right] in *.
        eauto 10 using @only_differ_sym, @only_differ_put, @only_differ_trans with typeclass_instances. }
      { constructor; eauto; [ ].
        sepsimpl; [ lia .. | ].
        cbn [rep.rtype_of_ltype rep.Z].
        eexists; sepsimpl; [ reflexivity | ].
        eapply expr_untouched with (mem2:=map.empty); eauto;
          [ | solve [apply dexpr_put_same] ].
        match goal with H : PropSet.sameset _ _ |- _ =>
                        rewrite sameset_iff in H;
                          rewrite H
        end.
        rewrite used_varnames_iff; intro; cleanup.
        match goal with H : varname_gen _ = varname_gen _ |- _ =>
                        apply varname_gen_unique in H end.
        lia. } }
  Qed.

  Lemma assign_base_correct {t} :
    forall (x : base.interp t)
           (rhs : base_rtype t)
           (nextn : nat)
           tr
           (mem : mem)
           (locals : locals)
           functions,
      (* rhs == x *)
      locally_equivalent_base x rhs locals ->
      (* locals don't contain any variables we can overwrite *)
      (forall n nvars,
          (nextn <= n)%nat ->
          map.undef_on locals (used_varnames (varname_gen:=varname_gen) n nvars)) ->
      let out := assign_base nextn rhs in
      let nvars := fst (fst out) in
      let lhs := snd (fst out) in
      WeakestPrecondition.cmd
        (WeakestPrecondition.call functions)
        (snd out) tr mem locals
        (fun tr' mem' locals' =>
           tr = tr'
           (* assign never stores anything -- mem unchanged *)
           /\ mem = mem'
           (* return values match the number of variables used *)
           /\ PropSet.sameset (varname_set_base lhs)
                              (used_varnames (varname_gen:=varname_gen) nextn nvars)
           (* new locals only differ in the values of LHS variables *)
           /\ map.only_differ locals (varname_set_base lhs) locals'
           (* evaluating lhs == x *)
           /\ locally_equivalent_base x (base_rtype_of_ltype lhs) locals').
  Proof.
    cbv zeta. cbv [locally_equivalent_base].
    induction t; cbn [assign_base equivalent_base fst snd];
      break_match; intros; sepsimpl; [ | | ].
    { (* base_Z *)
      cbn [rep.Z rep.equiv rep.varname_set
                 rep.rtype_of_ltype
                 varname_set_base
                 base_rtype_of_ltype] in *.
      sepsimpl. repeat straightline.
      eexists; split;
        [ apply expr_empty; eassumption | ].
      repeat (split; [reflexivity | ]).
      repeat match goal with |- _ /\ _ => split end;
        try eexists; sepsimpl;
        eauto using @dexpr_put_same, @only_differ_sym, @only_differ_put with typeclass_instances.
      all:cbv [PropSet.singleton_set]; apply sameset_iff; intros.
      all:rewrite used_varnames_iff; split; intros; cleanup; subst; eauto;
        first [ eexists; eauto with lia
              | f_equal; lia ]. }
    { (* prod *)
      repeat straightline.
      eapply Proper_cmd; [ solve [apply Proper_call]
                         | repeat intro | eapply IHt1; solve [eauto] ].
      cbv beta in *; cleanup; subst.
      eapply Proper_cmd; [ solve [apply Proper_call] | repeat intro | ].
      2:{
        eapply IHt2; eauto; [ | ].
         { eapply equivalent_only_differ_undef; eauto;
             try exact equiv_listZ_only_differ_undef_local.
           match goal with H : PropSet.sameset _ _ |- _ =>
                           rewrite H end.
           eauto. }
         { intros.
           eapply only_differ_disjoint_undef_on;
             try eapply undef_on_subset;
             eauto using used_varnames_subset with lia.
           match goal with H : PropSet.sameset _ _ |- _ =>
                           rewrite H end.
           apply used_varnames_disjoint; lia. } }
      cbv beta in *; cleanup; subst.
      cbn [varname_set_base base_rtype_of_ltype fst snd].
      repeat match goal with |- _ /\ _ => split end;
        eauto 10 using @only_differ_sym, @only_differ_trans with typeclass_instances; [ | ].
      { rewrite used_varnames_union.
        repeat match goal with H : PropSet.sameset _ _ |- _ =>
                               rewrite H end.
        reflexivity. }
      { apply sep_empty_iff; split; eauto; [ ].
        eapply equivalent_only_differ; eauto with equiv.
        repeat match goal with H : PropSet.sameset _ _ |- _ =>
                               rewrite H end.
        symmetry.
        apply used_varnames_disjoint; lia. } }
    { (* base_listZ *)
      eapply assign_list_correct; eauto. }
  Qed.

  Lemma assign_correct {t} :
    forall (x : API.interp_type t)
           (rhs : rtype t)
           (nextn : nat)
           tr
           (mem : mem)
           (locals : locals)
           functions,
      (* rhs == x *)
      locally_equivalent x rhs locals ->
      (* locals don't contain any variables we can overwrite *)
      (forall n nvars,
          (nextn <= n)%nat ->
          map.undef_on locals (used_varnames (varname_gen:=varname_gen) n nvars)) ->
      let out := assign nextn rhs in
      let nvars := fst (fst out) in
      let lhs := snd (fst out) in
      WeakestPrecondition.cmd
        (WeakestPrecondition.call functions)
        (snd out) tr mem locals
        (fun tr' mem' locals' =>
           tr = tr'
           (* assign never stores anything -- mem unchanged *)
           /\ mem = mem'
           (* return values match the number of variables used *)
           /\ PropSet.sameset (varname_set lhs)
                              (used_varnames (varname_gen:=varname_gen) nextn nvars)
           (* new locals only differ in the values of LHS variables *)
           /\ map.only_differ locals (varname_set lhs) locals'
           (* evaluating lhs == x *)
           /\ locally_equivalent x (rtype_of_ltype _ lhs) locals').
  Proof.
    destruct t;
      cbn [locally_equivalent equivalent varname_set];
      [ apply assign_base_correct | tauto ].
  Qed.

  (* if e is a valid_expr, it will hit the cases that call translate_expr *)
  Lemma translate_cmd_valid_expr {t}
        (e1 : @API.expr (fun _ => unit) t)
        (e2 : @API.expr API.interp_type t)
        (e3 : @API.expr ltype t)
        G nextn :
    valid_expr true e1 ->
    wf3 G e1 e2 e3 ->
    translate_cmd e3 nextn = assign nextn (translate_expr true e3).
  Proof.
    inversion 1; cleanup_wf; try reflexivity; intros.
    all: repeat first [ reflexivity
                      | match goal with
                        | [ H : wf3 _ ?x _ _ |- _ ]
                          => assert_fails is_var x; inversion H; clear H; cleanup_wf
                        end ].
  Qed.

  Local Ltac simplify :=
    repeat
      first [ progress (intros; cleanup)
            | progress
                cbn [fst snd assign assign_base context_varname_set
                         varname_set varname_set_base
                         ltype rtype base_ltype base_rtype rtype_of_ltype
                         base_rtype_of_ltype rep.rtype_of_ltype
                         rep.equiv rep.listZ_local rep.Z
                         locally_equivalent equivalent
                         locally_equivalent_base equivalent_base
                         map Datatypes.length Compilers.ident_interp] in *
            | match goal with |- _ /\ _ => split end ].

  Local Ltac setsimplify :=
    repeat match goal with
           | _ => progress cbv [PropSet.union PropSet.of_list
                                              PropSet.singleton_set PropSet.elem_of] in *
           | H : PropSet.sameset _ _ |- _ => rewrite sameset_iff in H; rewrite H
           end.

  (* prove that context doesn't include overwritable variables *)
  Local Ltac context_not_overwritable :=
    repeat match goal with
           | _ => progress (intros; cleanup)
           | _ => progress
                    cbn [ltype base_ltype assign_base context_varname_set
                               varname_set_base varname_set fst snd] in *
           | _ => progress setsimplify
           | _ => apply Forall_cons; [ | solve [eauto with lia] ]
           | _ => rewrite used_varnames_iff
           | H : varname_gen _ = varname_gen _ |- _ =>
             apply varname_gen_unique in H; subst
           | |- ~ (_ \/ _) =>
             let X := fresh in intro X; destruct X; cleanup
           | H : context [context_varname_set] |- _ =>
             eapply H; try eassumption; lia
           | _ => lia
           end.

  (* prove that paired variable values in the context are equivalent *)
  Local Ltac context_equiv_ok :=
    repeat match goal with
           | _ => progress (intros; cleanup)
           | |- context_equiv (_ :: _) _ =>
             apply Forall_cons; [ solve [eauto] | ]
           | _ =>
             eapply equivalent_not_in_context_forall;
               eauto using disjoint_sameset, disjoint_used_varnames_lt
           | _ => solve [subst; eauto]
           end.

  Local Ltac new_context_ok :=
    match goal with
    | |- context_equiv _ _ => context_equiv_ok
    | _ => context_not_overwritable
    end.

  Local Ltac only_differ_ok :=
       repeat match goal with
              | _ => eapply only_differ_step; try eassumption; [ ]
              | _ => eapply Proper_only_differ; eauto;
                     solve[symmetry; eauto]
              end.

  Lemma translate_cmd_correct {t}
        (* three exprs, representing the same Expr with different vars *)
        (e1 : @API.expr (fun _ => unit) t)
        (e2 : @API.expr API.interp_type t)
        (e3 : @API.expr ltype t)
        (* e1 is valid input to translate_cmd *)
        (e1_valid : valid_cmd e1)
        (* context list *)
        (G : list _) :
    (* exprs are all related *)
    wf3 G e1 e2 e3 ->
    forall functions
           (locals : locals)
           (nextn : nat),
      (* ret := fiat-crypto interpretation of e2 *)
      let ret1 : API.interp_type t := API.interp e2 in
      (* out := translation output for e3 *)
      let out := translate_cmd e3 nextn in
      let nvars := fst (fst out) in
      let ret2 := rtype_of_ltype _ (snd (fst out)) in
      let body := snd out in
      (* G doesn't contain variables we could accidentally overwrite *)
      (forall n,
          (nextn <= n)%nat ->
          ~ context_varname_set G (varname_gen n)) ->
      (* locals don't contain any variables we can overwrite *)
      (forall n nvars,
          (nextn <= n)%nat ->
          map.undef_on locals (used_varnames(varname_gen:=varname_gen) n nvars)) ->
      forall tr
             (mem : mem),
        (* contexts are equivalent; for every variable in the context list G,
             the fiat-crypto and bedrock2 results match *)
        context_equiv G locals ->
        (* executing translation output is equivalent to interpreting e *)
        WeakestPrecondition.cmd
          (WeakestPrecondition.call functions)
          body tr mem locals
          (fun tr' mem' locals' =>
             tr = tr' /\
             mem = mem' /\
             PropSet.subset
               (varname_set (snd (fst out)))
               (used_varnames(varname_gen:=varname_gen) nextn nvars) /\
             map.only_differ
               locals (used_varnames(varname_gen:=varname_gen) nextn nvars) locals' /\
             locally_equivalent ret1 ret2 locals').
  Proof.
    revert e2 e3 G. cbv zeta.
    induction e1_valid; try (inversion 1; [ ]).

    (* inversion on wf3 leaves a mess; clean up hypotheses *)
    all:repeat match goal with
               | _ => progress cleanup_wf
               | _ => progress cbn [varname_set]
               | H : wf3 _ ?x ?y _ |- _ =>
                 (* for the cons case, repeatedly do inversion until the cons is exposed *)
                 progress match x with
                            context [Compilers.ident.cons] =>
                            progress match y with
                                     | expr.App _ _ => idtac (* don't invert original, already-inverted one *)
                                     | _ => inversion H; clear H
                                     end
                          end
               end.

    (* simplify goals *)
    all:repeat match goal with
               | _ => progress (intros; cleanup)
               | _ => progress cbv [Rewriter.Util.LetIn.Let_In] in *
               | _ => erewrite translate_cmd_valid_expr by eauto
               | _ => progress cbn [translate_cmd expr.interp type.app_curried
                                                  WeakestPrecondition.cmd
                                                  WeakestPrecondition.cmd_body] in *
               | _ => eapply Proper_cmd;
                        [ eapply Proper_call | repeat intro
                          | eapply assign_correct; eauto;
                            eapply translate_expr_correct; solve [eauto] ]
               | _ => progress cbn [invert_expr.invert_pair_cps invert_expr.invert_AppIdent2_cps Option.bind invert_expr.invert_App2_cps invert_expr.invert_App_cps invert_expr.invert_Ident invert_expr.is_pair Compilers.invertIdent Option.bind translate_ident2_for_cmd Crypto.Util.Option.bind]
               end.

    { (* let-in (product of base types) *)
      eapply Proper_cmd; [ eapply Proper_call | repeat intro | ].
      2: {
        eapply IHe1_valid; clear IHe1_valid;
        repeat match goal with
               | _ => progress (intros; cleanup)
               | _ => solve [new_context_ok]
               | H : _ |- _ => solve [apply H]
               | _ => congruence
               end; [ ].
        eapply only_differ_disjoint_undef_on; eauto with lia; [ ].
        match goal with H : PropSet.sameset _ _ |- _ =>
                        rewrite H end.
        apply used_varnames_disjoint; lia. }
      { simplify; subst; eauto; only_differ_ok.
        etransitivity; [ eassumption | ].
        apply used_varnames_shift. } }
    { (* let-in (base type) *)
      eapply Proper_cmd; [ eapply Proper_call | repeat intro | ].
      2: {
        eapply IHe1_valid; clear IHe1_valid;
        repeat match goal with
               | _ => progress (intros; cleanup)
               | _ => solve [new_context_ok]
               | H : _ |- _ => solve [apply H]
               | _ => congruence
               end; [ ].
        eapply only_differ_disjoint_undef_on; eauto with lia; [ ].
        match goal with H : PropSet.sameset _ _ |- _ =>
                        rewrite H end.
        apply used_varnames_disjoint; lia. }
      { simplify; subst; eauto; only_differ_ok.
        etransitivity; [ eassumption | ].
        apply used_varnames_shift. } }
    { (* cons *)
      eapply Proper_cmd; [ eapply Proper_call | repeat intro | ].
      2: {
        eapply IHe1_valid with (G:=G); clear IHe1_valid;
        repeat match goal with
               | _ => progress (intros; cleanup)
               | H : _ |- _ => solve [apply H]
               | _ => solve [new_context_ok]
               | _ => congruence
               end; [ ].
        eapply only_differ_disjoint_undef_on; eauto with lia; [ ].
        match goal with H : PropSet.sameset _ _ |- _ =>
                        rewrite H end.
        apply used_varnames_disjoint; lia. }
      { simplify; subst; eauto; [ | | ].
        { (* varnames subset *)
          rewrite varname_set_local.
          rewrite PropSet.of_list_cons.
          rewrite add_union_singleton.
          apply subset_union_l;
            [ apply used_varnames_subset_singleton; lia| ].
          rewrite <-varname_set_local.
          etransitivity; [eassumption|].
          rewrite <-Nat.add_1_r.
          apply used_varnames_shift. }
        { (* only_differ *)
          rewrite <-(Nat.add_comm nextn 1) in *.
          only_differ_ok. }
        { (* equivalence of output holds *)
          clear IHe1_valid.
          simplify. cbv [WeakestPrecondition.dexpr] in *.
          apply Forall2_cons; [intros | eassumption].
          sepsimpl.
          eexists; sepsimpl; [ eassumption | ].
          eapply (expr_untouched ltac:(eassumption)
                                        ltac:(eassumption)); eauto; [ ].
          cbv [used_varnames]. setsimplify.
          rewrite in_map_iff. intro; cleanup.
          match goal with H : varname_gen ?x = varname_gen _ |- _ =>
                          apply varname_gen_unique in H; subst x end.
          match goal with H : In _ (seq _ _) |- _ =>
                          apply in_seq in H end.
          lia. } } }
    { (* nil *)
      cbv [locally_equivalent equivalent]; simplify; eauto;
        try reflexivity.
      right; reflexivity. }
    { (* valid expr *)
      simplify; subst; eauto; only_differ_ok.
      match goal with H : PropSet.sameset _ _ |- _ =>
                      rewrite H end; reflexivity. }
  Qed.
End Cmd.