From iVM Require Import Init DSet Lens Extras.Mixer.

Require Import Coq.Logic.ProofIrrelevance.

Unset Suggest Proof Using.

(** ** Extensionality *)

Section ext_section.

  Local Arguments proj {_ _} _ _.
  Local Arguments update {_ _} _ _ _.

  Context {A X} (L1 L2: Lens A X).

  Lemma lensEq_eq (H: L1 ≅ L2) : L1 = L2.
  Proof.
    destruct L1 as [p1 u1 pu1 up1 uu1].
    destruct L2 as [p2 u2 pu2 up2 uu2].
    cbn in H.

    assert (u1 = u2) as Hu;
      [ extensionality a; extensionality x; apply H
      | subst u1 ].

    assert (p1 = p2) as Hp;
      [ extensionality a;
        setoid_rewrite <- up2 at 1;
        apply pu1
      | subst p1 ].

    f_equal; apply proof_irrelevance.
   Qed.

End ext_section.

(** ** Every mixer is a product lens (assuming extensionality) *)

Section mixer_section.

  Arguments exist {_ _}.

  Context {A} (f: Mixer A).

  Proposition mix_lens1_prop
              (g: A -> A) (H: forall a b, f a (g b) = g a)
              a b : g (f a b) = g a.
  Proof.
    transitivity (f (f a b) (g a)).
    + now rewrite H.
    + mixer_rewrite0. now rewrite H.
  Qed.

  Let X := { g : A -> A | forall a b, f a (g b) = g a }.

  #[refine] Instance mix_lens1 : Lens A X :=
  {
    proj a := exist (fun b => f b a) _;
    update a x := proj1_sig x a;
  }.
  Proof.
    - abstract mixer_rewrite'.
    - intros a [h H]. cbn.
      apply subset_eq_compat. extensionality b.
      apply H.
    - intros a. cbn. now mixer_rewrite0.
    - intros a [h H] [h' H']. cbn.
      transitivity (h' (f a (h a))).
      + now rewrite H.
      + now rewrite mix_lens1_prop.
  Defined.

  Proposition mix_lens2_prop
              (g: A -> A) (H: forall a b, f (g a) b = g b)
              a b : g (f a b) = g b.
  Proof.
    transitivity (f (g b) (f a b)).
    + now rewrite H.
    + mixer_rewrite0. now rewrite H.
  Qed.

  Let Y := { g : A -> A | forall a b, f (g a) b = g b }.

  #[refine] Instance mix_lens2 : Lens A Y :=
  {
    proj a := exist (fun b => f a b) _;
    update a x := proj1_sig x a;
  }.
  Proof.
    - mixer_rewrite'.
    - intros a [h H]. cbn.
      apply subset_eq_compat. extensionality b.
      apply H.
    - intros a. cbn. now mixer_rewrite0.
    - intros a [h H] [h' H']. cbn.
      transitivity (h' (f (h a) a)).
      + now rewrite H.
      + now rewrite mix_lens2_prop.
  Defined.

  Instance mix_ind : Independent mix_lens1 mix_lens2.
  Proof. mixer_rewrite'. Qed.

  Lemma mix_inj a b (Hx: proj a = proj b :> X) (Hy: proj a = proj b :> Y) : a = b.
  Proof.
    inversion Hx as [Hx'].
    inversion Hy as [Hy'].
    transitivity (f a a); [now mixer_rewrite0|];
      transitivity (f b b); [|now mixer_rewrite0].
    change (f a a) with ((fun x => f x a) a). rewrite Hx'.
    change (f a b) with ((fun x => f a x) b). rewrite Hy'.
    reflexivity.
  Qed.

End mixer_section.

(** ** Elementary *)

Section elementary_section.

  (** Since "unit" shorter than "terminal". *)
  #[refine] Instance unitLens {A} : Lens A unit :=
  {
    proj _ := tt;
    update a _ := a;
  }.
  Proof.
    1: intros _ [].
    all: reflexivity.
  Defined.

  Program Instance independent_unit {A X} {Lx: Lens A X} : Independent unitLens Lx.

  Instance unitSublens {A X} (Lx: Lens A X) : (Lx | idLens).
  Proof.
    intros a b c. reflexivity.
  Qed.

  #[refine] Instance falseLens {X} : Lens False X :=
  {
    proj a := False_rect X a;
    update a x := a;
  }.
  Proof.
    all: intros [].
  Defined.

  Instance independent_False {X Y} {Ly: Lens False Y} : Independent (@falseLens X) Ly.
  Proof.
    split; intros [].
  Qed.

  Context {A X} (Lx: Lens A X).

  Instance terminal_sublens : (Lx | idLens ).
  Proof.
    intros a b c. reflexivity.
  Qed.

  Instance initial_sublens : (unitLens | Lx).
  Proof.
    intros a b c. reflexivity.
  Qed.

  Context {Y} (Ly: Lens A Y) {Hi: Independent Lx Ly}.

  Arguments proj {_ _} _ _.
  Arguments update {_ _} _ _ _.

  (* TODO: Can we manage without these two propositions? *)
  Proposition prod_proj_spec (a: A) : proj (Lx * Ly) a = (proj Lx a, proj Ly a).
  Proof. reflexivity. Qed.

  Proposition prod_update_spec (a: A) (xy: X * Y) :
    update (Lx * Ly) a xy = update Ly (update Lx a (fst xy)) (snd xy).
  Proof. reflexivity. Qed.

End elementary_section.

(** ** Bijections *)

Class Bijection {X Y: Type} (f: X -> Y) :=
{
  inverse : Y -> X;
  inverse_f x : inverse (f x) = x;
  f_inverse y : f (inverse y) = y;
}.

Definition bijection {X Y: Type} (f: X -> Y) (g: Y -> X) : Prop :=
  forall x y, f x = y <-> g y = x.

Section bijection_section.

  Context {X: Type}.

  Program Instance Bijection_id : Bijection (@id X).

  Context {Y} {f: X -> Y}.

  #[refine] Instance Bijection_b (g: Y -> X) (Hb: bijection f g) : Bijection f :=
  {
    inverse := g;
    inverse_f x := _;
    f_inverse y := _;
  }.
  Proof.
    all: apply Hb; reflexivity.
  Defined.

  Context {Bf: Bijection f}.

  Lemma B_bijection : bijection f inverse.
  Proof.
    intros x y. split; intro; subst.
    - apply inverse_f.
    - apply f_inverse.
  Qed.

  Lemma B_injective x x' : f x = f x' -> x = x'.
    intros H.
    rewrite <- (proj1 (B_bijection x (f x')) H).
    apply inverse_f.
  Qed.

  (** Not global on purpose! *)
  Instance Bijection_symmetry : Bijection inverse :=
  {
    inverse := f;
    inverse_f := f_inverse;
    f_inverse := inverse_f;
  }.

  Context {Z} {g: Y -> Z} {Bg: Bijection g}.

  #[refine] Instance Bijection_composite : Bijection (g ∘ f) :=
  {
    inverse z := inverse (inverse z);
  }.
  Proof.
    all: intro; unfold compose.
    - do 2 rewrite inverse_f. reflexivity.
    -  do 2 rewrite f_inverse. reflexivity.
  Defined.

End bijection_section.

Arguments Bijection_b : clear implicits.
Arguments Bijection_b {_ _ _} _ _.

Arguments Bijection_composite : clear implicits.
Arguments Bijection_composite {_ _ _} _ {_ _}.

(** ** Bijection lenses *)

Notation Bijection_lens L := (Bijection (proj (Lens:=L))).

Section bijection_lens_section.

  Context {A X} {f: A -> X} (Bf: Bijection f).

  #[refine] Instance lens_bijection : Lens A X :=
  {
    proj x := f x;
    update _ x := inverse x;
  }.
  Proof.
    - intros _ x. apply f_inverse.
    - intros a. apply inverse_f.
    - reflexivity.
  Defined.

End bijection_lens_section.

Section lens_bijection_section.

  Context {A X} {Lx: Lens A X}.

  Proposition proj_characterized a x : proj a = x <-> update a x = a.
  Proof.
    split; intros H; rewrite <- H.
    - apply update_proj.
    - apply proj_update.
  Qed.

  Proposition update_as_inverse {Bp: Bijection proj} a x :
    update a x = inverse x.
  Proof.
    symmetry. apply B_bijection, proj_update.
  Qed.

  (** Conversely: *)

  #[refine] Instance bijection_lens (g: X -> A)
            (Hup: forall a x, update a x = g x) : Bijection_lens Lx :=
  {
    inverse := g;
  }.
  Proof.
    - intro a. rewrite <- (Hup a). apply proj_characterized. reflexivity.
    - intro x. rewrite <- (Hup (g x)). rewrite proj_update. reflexivity.
  Defined.

End lens_bijection_section.

(** ** Products and projections *)

Section projection_section.

  Context {X Y: Type}
          {A} (Lx: Lens A X) (Ly: Lens A Y) {IXY: Independent Lx Ly}
          {Bp: Bijection_lens (Lx * Ly)}.

  Local Ltac update_prod_tac a :=
    apply (B_injective (Bf:=Bp));
    rewrite <- (update_as_inverse a);
    rewrite proj_update;
    simpl;
    lens_rewrite.

  Proposition update_prodX (a: A) (x: X) : update a x = inverse (x, proj a).
  Proof. update_prod_tac a. Qed.

  Proposition update_prodY (a: A) (y: Y) : update a y = inverse (proj a, y).
  Proof. update_prod_tac a. Qed.

  (* TODO: Is this ever useful? *)
  Lemma update_proj_swap (a a' : A) :
    update a' (proj a : X) = update a (proj a' : Y).
  Proof. rewrite update_prodX, update_prodY. reflexivity. Qed.

  Proposition projX_inverse xy : proj (inverse xy) = fst xy.
  Proof.
    rewrite
      <- (update_as_inverse (inverse xy)),
      prod_update_spec,
      proj1_update2,
      proj_update.
    reflexivity.
  Qed.

  Proposition projY_inverse xy : proj (inverse xy) = snd xy.
  Proof.
    rewrite
      <- (update_as_inverse (inverse xy)),
      prod_update_spec,
      proj_update.
    reflexivity.
  Qed.

End projection_section.

(** ** Sum lenses *)

Section sum_section.

  Context {A B X : Type} {Lx : Lens A X} {Ly : Lens B X}.

  #[refine] Instance lens_sum : Lens (A + B) X :=
  {
    proj ab := match ab with inl a => proj a | inr b => proj b end;
    update ab x := match ab with inl a => inl (update a x) | inr b => inr (update b x) end;
  }.
  Proof.
    - intros [a|b] x; lens_rewrite.
    - intros [a|b]; f_equal; lens_rewrite.
    - intros [a|b] x x'; f_equal; lens_rewrite.
  Defined.

End sum_section.

(** ** Prisms

This is essentially a formalization of "prisms" in funcitonal programming.
I am not sure if our axiomatization is optimal. *)

Class Prism (X: Type) (A: Type) :=
{
  inj : X -> A;
  injected : A -> option X;
  injected_inj x : injected (inj x) = Some x;
  injected_some a x : injected a = Some x -> inj x = a;
}.

Arguments injected_some {_ _ _ _ _}.

Import DSetNotations.

Definition prism_dset {X A} (P: Prism X A) : DSet A :=
  DSet.def (fun a => injected a).

#[refine] Instance dset_prism {A} (u: DSet A) : Prism { a: A | a ∈ u } A :=
{
  inj x := proj1_sig x;
  injected a := match decide (a ∈ u) with
                | left Ha => Some (exist _ a Ha)
                | right _ => None
                end;
}.
Proof.
  - intros [a Ha]. cbn.
    decided Ha. reflexivity.
  - intros a [a' Ha'] H.
    cbn.
    destruct (decide (a ∈ u)) as [Ha|Ha]; [ | discriminate H ].
    derive H (noConfusion_inv H).
    cbn in H.
    derive H (f_equal (@proj1_sig A _) H).
    symmetry.
    exact H.
Defined.

Notation Bijection_prism P := (Bijection (inj (Prism:=P))).

Section bijection_prism_section.

  Context {X A} {f: X -> A} (Bf: Bijection f).

  #[refine] Instance prism_bijection : Prism X A :=
  {
    inj := f;
    injected a := Some (inverse a);
  }.
  Proof.
    - intros x. f_equal. apply inverse_f.
    - intros a x H. injection H. intro. subst x. apply f_inverse.
  Qed.

End bijection_prism_section.

Section prism_basics_section.

  Context A {X} (PX: Prism X A).

  Lemma inj_extract a (H: injected a) : inj (extract H) = a.
  Proof.
    destruct (injected a) as [x|] eqn:Ha.
    - apply injected_some. exact Ha.
    - exact (none_rect H).
  Qed.

  Proposition inj_is_injected (x: X) : injected (inj x).
  Proof. apply (is_some_eq (injected_inj x)). Defined.

  Proposition extract_inj (x: X) : extract (inj_is_injected x) = x.
  Proof.
    unfold inj_is_injected.
    rewrite extract_is_some_eq.
    reflexivity.
  Qed.

  Opaque inj_is_injected.

  Lemma inj_injective (x x': X) : inj x = inj x' -> x = x'.
  Proof. (* Not sure if this is the best proof of this fact. *)
    intros H.
    derive H (f_equal injected H).
    do 2 rewrite injected_inj in H.
    exact (noConfusion_inv H).
  Qed.

  Context {Y} (PY: Prism Y X).

  #[refine] Instance inj_composition : Prism Y A :=
  {
    inj y := inj (inj y);
    injected a := match injected a with
                  | Some x => injected x
                  | None => None
                  end;
  }.
  Proof.
    - intros y. do 2 rewrite injected_inj. reflexivity.
    - intros a y H.
      destruct (injected a) as [x|] eqn:Ha.
      + rewrite (injected_some H).
        rewrite (injected_some Ha).
        reflexivity.
      + destruct (noConfusion_inv H).
  Defined.

  (** [id] is a bijection and therefore a prism. Hence, we clearly have a
      monoid up to functional extensionality here as well. *)

End prism_basics_section.

Arguments inj_extract {_ _ _ _} _.
Arguments inj_is_injected {_ _ _} _.
Arguments extract_inj {_ _ _} _.
Arguments inj_injective {_ _ _ _ _} _.
Arguments inj_composition {_ _} _ {_} _.

(** From now on, make [X] explicit for clarity. *)
Arguments injected : clear implicits.
Arguments injected _ {_ _} _.

(** ** Disjoint prisms *)

Class Disjoint {X Y A} (PX: Prism X A) (PY: Prism Y A) : Prop :=
{
  injectedY_injX (x: X) : injected Y (inj x) = None;
  injectedX_injY (y: Y) : injected X (inj y) = None;
}.

Arguments injectedY_injX {_ _ _ _ _ _} _.
Arguments injectedX_injY {_ _ _ _ _ _} _.

Section disjoint_basics_section.

  Context {X Y A} {PX: Prism X A} {PY: Prism Y A}.

  (** Not global to avoid infinite loops. *)
  Instance disjoint_symm (D: Disjoint PX PY) :
    Disjoint PY PX.
  Proof.
    split.
    - apply injectedX_injY.
    - apply injectedY_injX.
  Qed.

  Lemma disjoint_spec : Disjoint PX PY <-> forall a, (injected X a) -> (injected Y a) -> False.
  Proof.
    split.
    - intros [Hyx Hxy].
      intros a Hx Hy.
      specialize (Hyx (extract Hx)).
      rewrite inj_extract in Hyx.
      rewrite Hyx in Hy.
      exact (none_is_false Hy).
    - intros H.
      split.
      + intros x.
        specialize (H (inj x)).
        destruct (injected Y (inj x)).
        exfalso.
        apply H.
        * apply inj_is_injected.
        * apply some_is_some.
        * reflexivity.
      + intros y.
        specialize (H (inj y)).
        destruct (injected X (inj y)).
        exfalso.
        apply H.
        * apply some_is_some.
        * apply inj_is_injected.
        * reflexivity.
  Qed.

End disjoint_basics_section.

(** ** Injection prisms *)

Section injection_section.

  Context {X Y : Type}.

  #[refine] Instance inj_inl: Prism X (X + Y) :=
  {
    inj := inl;
    injected a := match a with inl x => Some x | _ => None end;
  }.
  Proof.
    - intro x. reflexivity.
    - intros [x|y] x' H; destruct (noConfusion_inv H).
      reflexivity.
  Defined.

  #[refine] Instance inj_inr: Prism Y (X + Y) :=
  {
    inj := inr;
    injected a := match a with inr y => Some y | _ => None end;
  }.
  Proof.
    - intro y. reflexivity.
    - intros [x|y] y' H; destruct (noConfusion_inv H).
      reflexivity.
  Defined.

  Program Instance disjoint_ins : Disjoint inj_inl inj_inr.

  Context (A: Type).

  Context (PX: Prism X A) (PY: Prism Y A).

  #[refine] Instance inj_false : Prism False A :=
  {
    inj H := False_rect A H;
    injected _ := None;
  }.
  Proof.
    - intros [].
    - intros a x. destruct x.
  Defined.

  Instance inj_false_disjoint: Disjoint inj_false PX.
  Proof.
    split.
    - intros [].
    - intros y. reflexivity.
  Defined.

End injection_section.

(** ** Sum prisms *)

Section sum_section.

  Derive NoConfusion for sum.

  Context {A X Y} {PX: Prism X A} {PY: Prism Y A} (DXY: Disjoint PX PY).

  #[refine] Instance inj_sum : Prism (X + Y) A :=
  {
    inj xy := match xy with
              | inl x => inj x
              | inr y => inj y
              end;
    injected a := match injected X a, injected Y a with
                  | Some x, _ => Some (inl x)
                  | _, Some y => Some (inr y)
                  | _, _ => None
                  end;
  }.
  Proof.
    - intros [x|y]; rewrite injected_inj.
      + reflexivity.
      + rewrite injectedX_injY. reflexivity.
    - intros a [x|y] H; destruct (injected X a) as [x'|] eqn:Ha.
      + repeat derive H (noConfusion_inv H).
        simpl in H. subst x'.
        exact (injected_some Ha).
      + destruct (injected Y a) as [y|];
          exfalso; repeat derive H (noConfusion_inv H); exact H.
      + exfalso; repeat derive H (noConfusion_inv H); exact H.
      + destruct (injected Y a) as [y'|] eqn:Ha'.
        * repeat derive H (noConfusion_inv H).
          simpl in H. subst y'.
          exact (injected_some Ha').
        * exfalso; repeat derive H (noConfusion_inv H); exact H.
  Defined.

  Context Z {PZ: Prism Z A} (DXZ: Disjoint PX PZ) (DYZ: Disjoint PY PZ).

  Instance sum_disjoint : Disjoint inj_sum PZ.
  Proof. (* TODO: shorten? *)
    split.
    - intros [x|y].
      + apply (injectedY_injX (Disjoint:=DXZ)).
      + apply (injectedY_injX (Disjoint:=DYZ)).
    - intros z.
      simpl.
      destruct (injected X (inj z)) as [x|] eqn:Hi.
      + rewrite injectedX_injY in Hi.
        exfalso; exact (noConfusion_inv Hi).
      + destruct (injected Z (inj z)) as [y|] eqn:Hi';
          rewrite injectedX_injY;
          reflexivity.
  Qed.

End sum_section.

(** ** [N -> Z] prism *)

Tactic Notation "decide" "as" ident(H) :=
  match goal with
    [|- context [decide ?P]] =>
    let H := fresh H in (* Not sure why this is needed *)
    let HH := fresh in
    assert P as HH;
    [ | destruct (decide P) as [H|H];
        [ clear HH | exfalso; exact (H HH) ]]
end.

#[refine] Instance prism_N : Prism N Z :=
{
  inj x := Z.of_N x;
  injected z := if decide (0 <= z)%Z
                then Some (Z.to_N z)
                else None;
}.
Proof.
  - intros x.
    decide as H; [apply N2Z.is_nonneg|].
    f_equal.
    apply N2Z.id.
  - intros z x.
    destruct (decide _) as [H|H];
      [|intros HH; exfalso; exact (noConfusion_inv HH)].
    injection 1. intro. subst x.
    apply Z2N.id.
    exact H.
Defined.

Proposition injected_N {z: Z} : injected N z <-> (0 <= z)%Z.
Proof.
  simpl.
  destruct (decide _) as [H|H]; unfold is_some; simpl; tauto.
Qed.

(** ** Sublenses *)

Section sublens_section.

  Context {X A Y} {PX: Prism X A} {Ly: Lens A Y}.

  Context (H: forall x y, injected X (update (inj x) y)).

  #[refine] Instance sublens : Lens X Y :=
  {
    proj x := proj (inj x);
    update x y := extract (H x y);
  }.
  Proof.
    - intros x y. rewrite inj_extract, proj_update. reflexivity.
    - intros x. apply inj_injective.
      rewrite inj_extract, update_proj. reflexivity.
    - intros x y y'.
      apply inj_injective.
      repeat rewrite inj_extract.
      rewrite update_update.
      reflexivity.
  Defined.

  Proposition prism_proj_spec x : proj x = proj (inj x).
  Proof. reflexivity. Qed.

  Proposition prism_update_spec x y : update x y = extract (H x y).
  Proof. reflexivity. Qed.

  Proposition inj_prism_update x y : inj (update x y) = update (inj x) y.
  Proof. simpl. rewrite inj_extract. reflexivity. Qed.

End sublens_section.

(** ** Every lens is a product lens

Assuming functional extensionality and proof irrelevance, we have a
converse of [fstLens]: If [Lens S X], then [S ≅ X * S'] for some S'. *)

Section Inv_lens.

  Context S X (PX: Lens S X).

  Definition S' := { f: X -> S | forall x y, update (f x) y = f y }.

  Arguments exist {_} {_} _.

  #[refine]
  Instance inv_lens : Lens S S' :=
  {
    proj s := exist (update s) _;
    update s f := proj1_sig f (proj s);
  }.
  Proof.
    - intros x y. rewrite update_update. reflexivity.
    - intros s [f H].
      simpl.
      apply eq_sig_hprop.
      + intros. apply proof_irrelevance.
      + simpl. extensionality x.
        rewrite H. reflexivity.
    - intro s. simpl.
      rewrite update_proj. reflexivity.
    - intros s [f Hf] [g Hg]. simpl.
      rewrite <- (Hf (proj s)), proj_update. reflexivity.
  Defined.

  Instance inv_lens_independent : Independent inv_lens PX.
  Proof.
    intros a b c. cbn. lens_rewrite.
  Qed.

  Lemma inv_lens_inv (s: S) :
    let (fH, x) := proj (Lens:=_*_) s in
    proj1_sig fH x = s.
  Proof.
    simpl. rewrite update_proj. reflexivity.
  Qed.

End Inv_lens.


Require Export Smallstep_J.

Module STLCRef.
  Inductive ty: Type :=
  | ty_Nat: ty
  | ty_Unit: ty
  | ty_arrow: ty -> ty -> ty
  | ty_Ref: ty -> ty.

  Inductive tm: Type :=
  | tm_var: id -> tm
  | tm_app: tm -> tm -> tm
  | tm_abs: id -> ty -> tm -> tm
  | tm_nat: nat -> tm
  | tm_succ: tm -> tm
  | tm_pred: tm -> tm
  | tm_mult: tm -> tm -> tm
  | tm_if0: tm -> tm -> tm -> tm
  | tm_unit: tm
  | tm_ref: tm -> tm
  | tm_deref: tm -> tm
  | tm_assign: tm -> tm -> tm
  | tm_loc: nat -> tm.

  Tactic Notation "tm_cases" tactic(first) ident(c) :=
    first;
    [ Case_aux c "tm_var" | Case_aux c "tm_app"
      | Case_aux c "tm_abs" | Case_aux c "tm_zero"
      | Case_aux c "tm_succ" | Case_aux c "tm_pred"
      | Case_aux c "tm_mult" | Case_aux c "tm_if0"
      | Case_aux c "tm_unit" | Case_aux c "tm_ref"
      | Case_aux c "tm_deref" | Case_aux c "tm_assign"
      | Case_aux c "tm_loc"].

  Module ExampleVariables.
    Definition x := Id 0.
    Definition y := Id 1.
    Definition r := Id 2.
    Definition s := Id 3.
  End ExampleVariables.

  Inductive value : tm -> Prop :=
  | v_abs: forall x T t,
      value (tm_abs x T t)
  | v_nat: forall n,
      value (tm_nat n)
  | v_unit:
      value tm_unit
  | v_loc: forall l,
      value (tm_loc l).

  Hint Constructors value.

  Fixpoint subst (x:id) (s:tm) (t:tm): tm :=
    match t with
    | tm_var x' =>
      if beq_id x x' then s else t
    | tm_app t1 t2 =>
      tm_app (subst x s t1) (subst x s t2)
    | tm_abs x' T t1 =>
      if beq_id x x' then t else tm_abs x' T (subst x s t1)
    | tm_nat n =>
      t
    | tm_succ t1 =>
      (subst x s t1)
    | tm_pred t1 =>
      tm_pred (subst x s t1)
    | tm_mult t1 t2 =>
      tm_mult (subst x s t1) (subst x s t2)
    | tm_if0 t1 t2 t3 =>
      tm_if0 (subst x s t1) (subst x s t2) (subst x s t3)
    | tm_unit =>
      t
    | tm_ref t1 =>
      tm_ref (subst x s t1)
    | tm_deref t1 =>
      tm_deref (subst x s t1)
    | tm_assign t1 t2 =>
      tm_assign (subst x s t1) (subst x s t2)
    | tm_loc _ => t
    end.

  Definition tm_seq t1 t2 :=
    tm_app (tm_abs (Id 0) ty_Unit t2) t1.
  Definition store := list tm.

  Definition store_lookup (n: nat) (st: store) :=
    nth n st tm_unit.

  Fixpoint snoc {A:Type} (l: list A) (x: A): list A :=
    match l with
    | nil => x :: nil
    | h :: t => h :: snoc t x
    end.

  Lemma length_snoc: forall A (l: list A) x,
      length (snoc l x) = S (length l).
  Proof.
    induction l; intros; [auto | simpl; rewrite IHl; auto].
  Qed.

  Lemma nth_lt_snoc: forall A (l: list A) x d n,
      n < length l ->
      nth n l d = nth n (snoc l x) d.
  Proof.
    induction l as [| a l']; intros; try solve by inversion.
    Case "l = a :: l".
    destruct n; auto.
    simpl. apply IHl'.
    simpl in H.
    apply lt_S_n in H.
    assumption.
  Qed.

  Lemma nth_eq_snoc: forall A (l: list A) x d,
      nth (length l) (snoc l x) d = x.
  Proof.
    induction l; intros; [auto | simpl; rewrite IHl; auto].
  Qed.

  Fixpoint replace {A:Type} (n: nat) (x: A) (l: list A): list A :=
    match l with
    | nil => nil
    | h :: t =>
      match n with
      | O => x :: t
      | S n' => h :: replace n' x t
      end
    end.

  Lemma replace_nil: forall A n (x: A),
      replace n x [] = [].
  Proof.
    destruct n; auto.
  Qed.

  Lemma length_replace: forall A n x (l: list A),
      length (replace n x l) = length l.
  Proof.
    intros A n x l.
    generalize dependent n.
    induction l; intros n.
    destruct n; auto.
    destruct n; auto.
    simpl. rewrite IHl. auto.
  Qed.

  Lemma lookup_replace_eq: forall l t st,
      l < length st ->
      store_lookup l (replace l t st) = t.
    Proof with auto.
      intros l t st.
      unfold store_lookup.
      generalize dependent l.
      induction st as [| t' st]; intros l Hlen.
      Case "st = []".
      inversion Hlen.
      Case "st = t' :: st'".
      destruct l; simpl...
      apply IHst. simpl in Hlen. omega.
    Qed.

    Lemma lookup_replace_neq: forall l1 l2 t st,
        l1 <> l2 ->
        store_lookup l1 (replace l2 t st) = store_lookup l1 st.
    Proof with auto.
      unfold store_lookup.
      induction l1 as [|l1']; intros l2 t st Hneq.
      Case "l1 = 0".
      destruct st.
      SCase "st = []". rewrite replace_nil...
      SCase "st = _ :: _". destruct l2... contradict Hneq...
      Case "l1 = S l1'".
      destruct st as [| t2 st2].
      SCase "st = []". destruct l2...
      SCase "st = t2 :: st2".
      destruct l2...
      simpl; apply IHl1'...
    Qed.

    Reserved Notation "t1 '/' st1 '==>' t2 '/' st2"
             (at level 40, st1 at level 39, t2 at level 39).
    Inductive step: tm * store -> tm * store -> Prop :=
    | ST_AppAbs: forall x T t12 v2 st,
        value v2 ->
        tm_app (tm_abs x T t12) v2 / st ==> subst x v2 t12 / st
    | ST_App1: forall t1 t1' t2 st st',
        t1 / st ==> t1' / st' ->
        tm_app t1 t2 / st ==> tm_app t1' t2 / st'
    | ST_App2: forall v1 t2 t2' st st',
        value v1 ->
        t2 / st ==> t2' / st' ->
        tm_app v1 t2 / st ==> tm_app v1 t2' / st'
    | ST_SuccNat: forall n st,
        tm_succ (tm_nat n) / st ==> tm_nat (S n) / st
    | ST_Succ: forall t1 t1' st st',
        t1 / st ==> t1' / st' ->
        tm_succ t1 / st ==> tm_succ t1' / st'
    | ST_PredNat: forall n st,
        tm_pred (tm_nat n) / st ==> tm_nat (pred n) / st
    | ST_Pred: forall t1 t1' st st',
        t1 / st ==> t1' / st' ->
        tm_pred t1 / st ==> tm_pred t1' / st'
    | ST_MultNats: forall n1 n2 st,
        tm_mult (tm_nat n1) (tm_nat n2) / st ==> tm_nat (mult n1 n2) / st
    | ST_Mult1: forall t1 t2 t1' st st',
        t1 / st ==> t1' / st' ->
        tm_mult t1 t2 / st ==> tm_mult t1' t2 / st'
    | ST_Mult2: forall v1 t2 t2' st st',
        value v1 ->
        t2 / st ==> t2' / st' ->
        tm_mult v1 t2 / st ==> tm_mult v1 t2' / st'
    | ST_If0: forall t1 t1' t2 t3 st st',
        t1 / st ==> t1' / st' ->
        tm_if0 t1 t2 t3 / st ==> tm_if0 t1' t2 t3 / st'
    | ST_If0_Zero: forall t2 t3 st,
        tm_if0 (tm_nat 0) t2 t3 / st ==> t2 / st
    | ST_If0_Nonzero: forall n t2 t3 st,
        tm_if0 (tm_nat (S n)) t2 t3 / st ==> t3 / st
    | ST_RefValue: forall v1 st,
        value v1 ->
        tm_ref v1 / st ==> tm_loc (length st) / snoc st v1
    | ST_Ref: forall t1 t1' st st',
        t1 / st ==> t1' / st' ->
        tm_ref t1 / st ==> tm_ref t1' / st'
    | ST_DerefLoc: forall st l,
        l < length st ->
        tm_deref (tm_loc l) / st ==> store_lookup l st / st
    | ST_Deref: forall t1 t1' st st',
        t1 / st ==> t1' / st' ->
        tm_deref t1 / st ==> tm_deref t1' / st'
    | ST_Assign: forall v2 l st,
        value v2 ->
        l < length st ->
        tm_assign (tm_loc l) v2 / st ==> tm_unit / replace l v2 st
    | ST_Assign1: forall t1 t1' t2 st st',
        t1 / st ==> t1' / st' ->
        tm_assign t1 t2 / st ==> tm_assign t1' t2 / st'
    | ST_Assign2: forall v1 t2 t2' st st',
        value v1 ->
        t2 / st ==> t2' / st' ->
        tm_assign v1 t2 / st ==> tm_assign v1 t2' / st'
    where "t1 '/' st1 '==>' t2 '/' st2" := (step (t1, st1) (t2, st2)).

    Tactic Notation "step_cases" tactic(first) ident(c) :=
      first;
      [ Case_aux c "ST_AppAbs" | Case_aux c "ST_App1"
        | Case_aux c "ST_App2" | Case_aux c "ST_SuccNat"
        | Case_aux c "ST_Succ" | Case_aux c "ST_PredNat"
        | Case_aux c "ST_Pred" | Case_aux c "ST_MultNats"
        | Case_aux c "ST_Mult1" | Case_aux c "ST_Mult2"
        | Case_aux c "ST_If0" | Case_aux c "ST_If0_Zero"
        | Case_aux c "ST_If0_Nonzero" | Case_aux c "ST_RefValue"
        | Case_aux c "ST_Ref" | Case_aux c "ST_DerefLoc"
        | Case_aux c "ST_Deref" | Case_aux c "ST_Assign"
        | Case_aux c "ST_Assign1" | Case_aux c "ST_Assign2" ].

    Hint Constructors step.

    Definition stepmany := (refl_step_closure step).
    Notation "t1 '/' st '==>*' t2 '/' st'" := (stepmany (t1, st) (t2, st'))
                                                (at level 40, st at level 39, t2 at level 39).

    Definition context := partial_map ty.
    Definition store_ty := list ty.
    Definition store_ty_lookup (n: nat) (ST: store_ty) :=
      nth n ST ty_Unit.

    Inductive has_type: context -> store_ty -> tm -> ty -> Prop :=
    | T_Var: forall Gamma ST x T,
        Gamma x = Some T ->
        has_type Gamma ST (tm_var x) T
    | T_Abs: forall Gamma ST x T11 T12 t12,
        has_type (extend Gamma x T11) ST t12 T12 ->
        has_type Gamma ST (tm_abs x T11 t12) (ty_arrow T11 T12)
    | T_App: forall T1 T2 Gamma ST t1 t2,
        has_type Gamma ST t1 (ty_arrow T1 T2) ->
        has_type Gamma ST t2 T1 ->
        has_type Gamma ST (tm_app t1 t2) T2
    | T_Nat: forall Gamma ST n,
        has_type Gamma ST (tm_nat n) ty_Nat
    | T_Succ: forall Gamma ST t1,
        has_type Gamma ST t1 ty_Nat ->
        has_type Gamma ST (tm_succ t1) ty_Nat
    | T_Pred: forall Gamma ST t1,
        has_type Gamma ST t1 ty_Nat ->
        has_type Gamma ST (tm_pred t1) ty_Nat
    | T_Mult: forall Gamma ST  t1 t2,
        has_type Gamma ST t1 ty_Nat ->
        has_type Gamma ST t2 ty_Nat ->
        has_type Gamma ST (tm_mult t1 t2) ty_Nat
    | T_If0: forall Gamma ST t1 t2 t3 T,
        has_type Gamma ST t1 ty_Nat ->
        has_type Gamma ST t2 T ->
        has_type Gamma ST t3 T ->
        has_type Gamma ST (tm_if0 t1 t2 t3) T
    | T_Unit: forall Gamma ST,
        has_type Gamma ST tm_unit ty_Unit
    | T_Loc: forall Gamma ST l,
        l < length ST ->
        has_type Gamma ST (tm_loc l) (ty_Ref (store_ty_lookup l ST))
    | T_Ref: forall Gamma ST t1 T1,
        has_type Gamma ST t1 T1 ->
        has_type Gamma ST (tm_ref t1) (ty_Ref T1)
    | T_Deref: forall Gamma ST t1 T11,
        has_type Gamma ST t1 (ty_Ref T11) ->
        has_type Gamma ST (tm_deref t1) T11
    | T_Assign: forall Gamma ST t1 t2 T11,
        has_type Gamma ST t1 (ty_Ref T11) ->
        has_type Gamma ST t2 T11 ->
        has_type Gamma ST (tm_assign t1 t2) ty_Unit.

    Hint Constructors has_type.

    Tactic Notation "has_type_cases" tactic(first) ident(c) :=
      first;
      [ Case_aux c "T_Var" | Case_aux c "T_Abs" | Case_aux c "T_App"
        | Case_aux c "T_Nat" | Case_aux c "T_Succ" | Case_aux c "T_Pred"
        | Case_aux c "T_Mult" | Case_aux c "T_If0"
        | Case_aux c "T_Unit" | Case_aux c "T_Loc"
        | Case_aux c "T_Ref" | Case_aux c "T_Deref"
        | Case_aux c "T_Assign" ].

    Definition store_well_typed (ST: store_ty) (st: store) :=
      length ST = length st /\
      (forall l, l < length st ->
             has_type empty ST (store_lookup l st) (store_ty_lookup l ST)).

    Inductive extends: store_ty -> store_ty -> Prop :=
    | extends_nil: forall ST',
        extends ST' nil
    | extends_cons: forall x ST' ST,
        extends ST' ST ->
        extends (x::ST') (x::ST).

    Hint Constructors extends.

    Lemma extends_lookup: forall l ST ST',
        l < length ST ->
        extends ST' ST ->
        store_ty_lookup l ST' = store_ty_lookup l ST.
    Proof with auto.
      intros l ST ST' Hlen H.
      generalize dependent ST'.
      generalize dependent l.
      induction ST as [|a ST2]; intros l Hlen ST' HST'.
      Case "nil". inversion Hlen.
      Case "cons". unfold store_ty_lookup in *.
      destruct ST' as [|a' ST'2].
        SCase "ST' = nil".
        inversion HST'.
        SCase "ST' = a' :: ST'2".
        inversion HST'; subst.
        destruct l as [| l'].
        SSCase "l = 0"...
        SSCase "l = S l'".
        simpl.
        apply IHST2...
        simpl in Hlen.
        omega.
    Qed.

    Lemma length_extends: forall l ST ST',
        l < length ST ->
        extends ST' ST ->
        l < length ST'.
    Proof with eauto.
      intros.
      generalize dependent l.
      induction H0; intros l Hlen.
      inversion Hlen.
      simpl in *.
      destruct l; try omega.
      apply lt_n_S.
      apply IHextends.
      omega.
    Qed.

    Lemma extends_snoc: forall ST T,
        extends (snoc ST T) ST.
    Proof with auto.
      induction ST; intros T...
      simpl...
    Qed.

    Lemma extends_refl: forall ST,
        extends ST ST.
    Proof.
      induction ST; auto.
    Qed.

    Definition preservation_theorem := forall ST t t' T st st',
        has_type empty ST t T ->
        store_well_typed ST st ->
        t / st ==> t' / st' ->
        exists ST',
          (extends ST' ST /\
           has_type empty ST' t' T /\
           store_well_typed ST' st').

    Inductive appears_free_in: id -> tm -> Prop :=
    | afi_var: forall x,
        appears_free_in x (tm_var x)
    | afi_app1: forall x t1 t2,
        appears_free_in x t1 -> appears_free_in x (tm_app t1 t2)
    | afi_app2: forall x t1 t2,
        appears_free_in x t2 -> appears_free_in x (tm_app t1 t2)
    | afi_abs: forall x y T11 t12,
        y <> x ->
        appears_free_in x t12 ->
        appears_free_in x (tm_abs y T11 t12)
    | afi_succ: forall x t1,
        appears_free_in x t1 ->
        appears_free_in x (tm_succ t1)
    | afi_pred: forall x t1,
        appears_free_in x t1 ->
        appears_free_in x (tm_pred t1)
    | afi_mult1: forall x t1 t2,
        appears_free_in x t1 ->
        appears_free_in x (tm_mult t1 t2)
    | afi_mult2: forall x t1 t2,
        appears_free_in x t2 ->
        appears_free_in x (tm_mult t1 t2)
    | afi_if0_1: forall x t1 t2 t3,
        appears_free_in x t1 ->
        appears_free_in x (tm_if0 t1 t2 t3)
    | aif_if0_2: forall x t1 t2 t3,
        appears_free_in x t2 ->
        appears_free_in x (tm_if0 t1 t2 t3)
    | aif_if0_3: forall x t1 t2 t3,
        appears_free_in x t3 ->
        appears_free_in x (tm_if0 t1 t2 t3)
    | afi_ref: forall x t1,
        appears_free_in x t1 -> appears_free_in x (tm_ref t1)
    |_afi_deref: forall x t1,
        appears_free_in x t1 -> appears_free_in x (tm_deref t1)
    | afi_assign1: forall x t1 t2,
        appears_free_in x t1 -> appears_free_in x (tm_assign t1 t2)
    | afi_assign2: forall x t1 t2,
        appears_free_in x t2 -> appears_free_in x (tm_assign t1 t2).

    Tactic Notation "afi_cases" tactic(first) ident(c) :=
      first;
      [ Case_aux c "afi_var"
      | Case_aux c "afi_app1" | Case_aux c "afi_app2" | Case_aux c "afi_abs"
      | Case_aux c "afi_succ" | Case_aux c "afi_pred"
      | Case_aux c "afi_mult1" | Case_aux c "afi_mult2"
      | Case_aux c "afi_if0_1" | Case_aux c "afi_if0_2" | Case_aux c "afi_if0_3"
      | Case_aux c "afi_ref" | Case_aux c "afi_deref"
      | Case_aux c "afi_assign1" | Case_aux c "afi_assign2" ].

    Hint Constructors appears_free_in.

    Lemma free_in_context: forall x t T Gamma ST,
        appears_free_in x t ->
        has_type Gamma ST t T ->
        exists T', Gamma x = Some T'.
    Proof with eauto.
      intros.
      generalize dependent Gamma.
      generalize dependent T.
      afi_cases (induction H) Case;
intros; (try solve [inversion H0; subst; eauto]).
      Case "afi_abs".
      inversion H1; subst.
      apply IHappears_free_in in H8.
      apply not_eq_beq_id_false in H.
      rewrite extend_neq in H8; assumption.
    Qed.

    Lemma context_invariance: forall Gamma Gamma' ST t T,
        has_type Gamma ST t T ->
        (forall x, appears_free_in x t -> Gamma x = Gamma' x) ->
        has_type Gamma' ST t T.
    Proof with eauto.
      intros.
      generalize dependent Gamma'.
      has_type_cases (induction H) Case; intros...
      Case "T_Var".
      apply T_Var. symmetry. rewrite <- H...
      Case "T_Abs".
      apply T_Abs. apply IHhas_type; intros.
      unfold extend.
      remember (beq_id x x0) as e; destruct e...
      apply H0. apply afi_abs. apply beq_id_false_not_eq... auto.
      Case "T_App".
      eapply T_App.
      apply IHhas_type1...
      apply IHhas_type2...
      Case "T_Mult".
      eapply T_Mult.
      apply IHhas_type1...
      apply IHhas_type2...
      Case "T_If0".
      eapply T_If0.
      apply IHhas_type1...
      apply IHhas_type2...
      apply IHhas_type3...
      Case "T_Assign".
      eapply T_Assign.
      apply IHhas_type1...
      apply IHhas_type2...
    Qed.

    Lemma substitution_preserves_typing: forall Gamma ST x s S t T,
        has_type empty ST s S ->
        has_type (extend Gamma x S) ST t T ->
        has_type Gamma ST (subst x s t) T.
    Proof with eauto.
      intros Gamma ST x s S t T Hs Ht.
      generalize dependent Gamma.
      generalize dependent T.
      tm_cases (induction t) Case; intros T Gamma H;
inversion H; subst; simpl...
      Case "tm_var".
      rename i into y.
      remember (beq_id x y) as eq; destruct eq; subst.
      SCase "x = y".
      apply beq_id_eq in Heqeq; subst.
      rewrite extend_eq in H3.
      inversion H3; subst.
      eapply context_invariance...
      intros x Hcontra.
      destruct (free_in_context _ _ _ _ _ Hcontra Hs) as [T' HT'].
      inversion HT'.
      SCase "x <> y".
      apply T_Var.
      rewrite extend_neq in H3...
      Case "tm_abs". subst.
      rename i into y.
      remember (beq_id x y) as eq; destruct eq.
      SCase "x = y".
      apply beq_id_eq in Heqeq; subst.
      apply T_Abs. eapply context_invariance...
      intros. apply extend_shadow.
      SCase "x <> x0".
      apply T_Abs. apply IHt.
      eapply context_invariance...
      intros. unfold extend.
      remember (beq_id y x0) as e. destruct e...
      apply beq_id_eq in Heqe; subst.
      rewrite <- Heqeq...
    Qed.

    Lemma assign_pres_store_typing: forall ST st l t,
        l < length st ->
        store_well_typed ST st ->
        has_type empty ST t (store_ty_lookup l ST) ->
        store_well_typed ST (replace l t st).
    Proof with auto.
      intros ST st l t Hlen HST Ht.
      inversion HST; subst.
      split. rewrite length_replace...
      intros l' Hl'.
      remember (beq_nat l' l) as ll'; destruct ll'.
      Case "l' = l".
      apply beq_nat_eq in Heqll'; subst.
      rewrite lookup_replace_eq...
      Case "l' <> l".
      symmetry in Heqll'; apply beq_nat_false in Heqll'.
      rewrite lookup_replace_neq...
      rewrite length_replace in Hl'.
      apply H0...
    Qed.

    Lemma store_weaking: forall Gamma ST ST' t T,
        extends ST' ST ->
        has_type Gamma ST t T ->
        has_type Gamma ST' t T.
    Proof with eauto.
      intros. has_type_cases (induction H0) Case; eauto.
      Case "T_Loc".
      erewrite <- extends_lookup...
      apply T_Loc.
      eapply length_extends...
    Qed.

    Lemma store_well_typed_snoc: forall ST st t1 T1,
        store_well_typed ST st ->
        has_type empty ST t1 T1 ->
        store_well_typed (snoc ST T1) (snoc st t1).
    Proof with auto.
      intros.
      unfold store_well_typed in *.
      inversion H as [Hlen Hmatch]; clear H.
      rewrite !length_snoc.
      split...
      Case "types match".
      intros l Hl.
      unfold store_lookup, store_ty_lookup.
      apply le_lt_eq_dec in Hl; destruct Hl as [Hlt | Heq].
      SCase "l < length st".
      apply lt_S_n in Hlt.
      rewrite <- !nth_lt_snoc...
      apply store_weaking with ST. apply extends_snoc.
      apply Hmatch...
      rewrite Hlen...
      SCase "l = length st".
      inversion Heq.
      rewrite nth_eq_snoc.
      rewrite <- Hlen. rewrite nth_eq_snoc...
      apply store_weaking with ST...
      apply extends_snoc.
    Qed.

    Theorem preservation: forall ST t t' T st st',
        has_type empty ST t T ->
        store_well_typed ST st ->
        t / st ==> t' / st' ->
                   exists ST',
                     (extends ST' ST /\
                      has_type empty ST' t' T /\
                      store_well_typed ST' st').
    Proof with eauto using store_weaking, extends_refl.
      remember (@empty ty) as Gamma.
      intros ST t t' T st st' Ht.
      generalize dependent t'.
      has_type_cases (induction Ht) Case; intros t' HST Hstep; subst; try (solve by inversion); inversion Hstep; subst; try (eauto using store_weaking, extends_refl).
      Case "T_App".
      SCase "ST_AppAbs". exists ST.
      inversion Ht1; subst.
      split; try split... eapply substitution_preserves_typing...
      SCase "ST_App1".
      eapply IHHt1 in H0...
      inversion H0 as [ST' [Hext [Hty Htsy]]].
      exists ST'...
      SCase "ST_App2".
      eapply IHHt2 in H5...
      inversion H5 as [ST' [Hext [Hty Htsy]]].
      exists ST'...
      Case "T_Succ".
      SCase "ST_Succ".
      eapply IHHt in H0...
      inversion H0 as [ST' [Hext [Hty Hsty]]].
      exists ST'...
      Case "T_Pred".
      SCase "ST_Pred".
      eapply IHHt in H0...
      inversion H0 as [ST' [Hext [Hty Hsty]]].
      exists ST'...
      Case "T_Mult".
      SCase "ST_Mult1".
      eapply IHHt1 in H0...
      inversion H0 as [ST' [Hext [Hty Hsty]]].
      exists ST'...
      SCase "ST_Mult2".
      eapply IHHt2 in H5...
      inversion H5 as [ST' [Hext [Hty Hsty]]].
      exists ST'...
      Case "T_If0".
      SCase "ST_If0_1".
      eapply IHHt1 in H0...
      inversion H0 as [ST' [Hext [Hty Hsty]]].
      exists ST'...
      split...
      Case "T_Ref".
      SCase "ST_RefValue".
      exists (snoc ST T1).
      inversion HST; subst.
      split. apply extends_snoc.
      split.
      replace (ty_Ref T1)
      with (ty_Ref (store_ty_lookup (length st) (snoc ST T1))).
      apply T_Loc.
      rewrite <- H. rewrite length_snoc. omega.
      unfold store_ty_lookup. rewrite <- H. rewrite nth_eq_snoc...
      apply store_well_typed_snoc; assumption.
      SCase "ST_Ref".
      eapply IHHt in H0...
      inversion H0 as [ST' [Hext [Hty Hsty]]].
      exists ST'...
      Case "T_Deref".
      SCase "ST_DerefLoc".
      exists ST. split; try split...
      destruct HST as [_ Hsty].
      replace T11 with (store_ty_lookup l ST).
      apply Hsty...
      inversion Ht; subst...
      SCase "ST_Deref".
      eapply IHHt in H0...
      inversion H0 as [ST' [Hext [Hty Hsty]]].
      exists ST'...
      Case "T_Assign".
      SCase "ST_Assign".
      exists ST. split; try split...
      eapply assign_pres_store_typing...
      inversion Ht1; subst...
      SCase "ST_Assign1".
      eapply IHHt1 in H0...
      inversion H0 as [ST' [Hext [Hty Hsty]]].
      exists ST'...
      SCase "ST_Assign2".
      eapply IHHt2 in H5...
      inversion H5 as [ST' [Hext [Hty Hsty]]].
      exists ST'...
    Qed.

    Theorem progress: forall ST t T st,
        has_type empty ST t T ->
        store_well_typed ST st ->
        (value t \/ exists t', exists st', t / st ==> t' / st').
    Proof with eauto.
      intros ST t T st Ht HSt.
      remember (@empty ty) as Gamma.
      has_type_cases (induction Ht) Case; subst; try solve by inversion...
      Case "T_App".
      right.
      destruct IHHt1 as [Ht1p | Htp1]...
      SCase "t1 is a value".
      inversion Ht1p; subst; try solve by inversion.
      destruct IHHt2 as [Ht2p | Ht2p]...
      SSCase "t2 steps".
      inversion Ht2p as [t2' [st' Hstep]].
      exists (tm_app (tm_abs x T t) t2'). exists st'...
      SCase "t1 steps".
      inversion Htp1 as [t1' [st' Hstep]]...
      Case "T_Succ".
      right. destruct IHHt as [Ht1p | Ht1p]...
      SCase "t1 is a value".
      inversion Ht1p; subst; try solve [inversion Ht].
      SSCase "t1 is a tm_nat".
      exists (tm_nat (S n)). exists st...
      SCase "t1 steps".
      inversion Ht1p as [t1' [st' Hstep]].
      exists (tm_succ t1'). exists st'...
      Case "T_Pred".
      right. destruct IHHt as [Ht1p | Ht1p]...
      SCase "t1 is a value".
      inversion Ht1p; subst; try solve [inversion Ht].
      SSCase "ti is a tm_nat".
      exists (tm_nat (pred n)).
      exists st...
      SCase "t1 steps".
      inversion Ht1p as [t1' [st' Hstep]].
      exists (tm_pred t1'). exists st'...
      Case "T_Mult".
      right. destruct IHHt1 as [Ht1p | Ht1p]...
      SCase "t1 is a value".
      inversion Ht1p; subst; try solve [inversion Ht1].
      destruct IHHt2 as [Ht2p | Ht2p]...
      SSCase "t2 is a value".
      inversion Ht2p; subst; try solve [inversion Ht2].
      exists (tm_nat (mult n n0)). exists st...
      SSCase "t2 steps".
      inversion Ht2p as [t2' [st' Hstep]].
      exists (tm_mult (tm_nat n) t2'). exists st'...
      SCase "t1 steps".
      inversion Ht1p as [t1' [st' Hstep]].
      exists (tm_mult t1' t2). exists st'...
      Case "T_If0".
      right. destruct IHHt1 as [Ht1p | Ht1p]...
      SCase "t1 is a value".
      inversion Ht1p; subst; try solve [inversion Ht1].
      destruct n.
      SSCase "n = 0". exists t2. exists st...
      SSCase "n = S n'". exists t3. exists st...
      SCase "t1 steps".
      inversion Ht1p as [t1' [st' Hstep]].
      exists (tm_if0 t1' t2 t3). exists st'...
      Case "T_Ref".
      right. destruct IHHt as [Ht1p | Ht1p]...
      SCase "t1 steps".
      inversion Ht1p as [t1' [st' Hstep]].
      exists (tm_ref t1'). exists st'...
      Case "T_Deref".
      right. destruct IHHt as [Ht1p | Ht1p]...
      SCase "t1 is a value".
      inversion Ht1p; subst; try solve by inversion.
      eexists. eexists. apply ST_DerefLoc...
      inversion Ht; subst. inversion HSt; subst.
      rewrite <- H...
      SCase "t1 steps".
      inversion Ht1p as [t1' [st' Hstep]].
      exists (tm_deref t1'). exists st'...
      Case "T_Assign".
      right. destruct IHHt1 as [Ht1p | Ht1p]...
      SCase "t1 is a value".
      destruct IHHt2 as [Ht2p | Ht2p]...
      SSCase "t2 is a value".
      inversion Ht1p; subst; try solve by inversion.
      eexists. eexists. apply ST_Assign...
      inversion HSt; subst. inversion Ht1; subst.
      rewrite H in H5...
      SSCase "t2 steps".
      inversion Ht2p as [t2' [st' Hstep]].
      exists (tm_assign t1 t2'). exists st'...
      SCase "t1 steps".
      inversion Ht1p as [t1' [st' Hstep]].
      exists (tm_assign t1' t2). exists st'...
    Qed.

    Section RefsAndNontermination.
      Import ExampleVariables.

      Definition loop_fun :=
        tm_abs x ty_Unit (tm_app (tm_deref (tm_var r)) tm_unit).

      Definition loop :=
        tm_app
          (tm_abs r (ty_Ref (ty_arrow ty_Unit ty_Unit))
                  (tm_seq (tm_assign (tm_var r) loop_fun)
                          (tm_app (tm_deref (tm_var r)) tm_unit)))
          (tm_ref (tm_abs x ty_Unit tm_unit)).

      Lemma loop_typable: exists T, has_type empty [] loop T.
      Proof with eauto.
        eexists. unfold loop. unfold loop_fun.
        eapply T_App...
        eapply T_Abs...
        eapply T_App...
        eapply T_Abs. eapply T_App. eapply T_Deref. eapply T_Var.
        unfold extend. simpl. reflexivity. auto.
        eapply T_Assign.
        eapply T_Var. unfold extend. simpl. reflexivity.
        eapply T_Abs.
        eapply T_App...
        eapply T_Deref. eapply T_Var. reflexivity.
      Qed.

      Inductive step_closure {X:Type} (R: relation X): X -> X -> Prop :=
      | sc_one: forall (x y: X),
          R x y -> step_closure R x y
      | sc_step: forall (x y z: X),
          R x y ->
          step_closure R y z ->
          step_closure R x z.

      Definition stepmany1 := (step_closure step).
      Notation "t1 '/' st '==>+' t2 '/' st'" := (stepmany1 (t1, st) (t2, st'))
                                                  (at level 40, st at level 39, t2 at level 39).
      Ltac print_goal := match goal with |- ?x => idtac x end.
      Ltac reduce :=
        repeat (print_goal; eapply rsc_step; [(eauto 10; fail) | (instantiate; compute)];
                try solve [apply rsc_refl]).

      Lemma loop_stops_to_loop_fun:
        loop / [] ==>*
             tm_app (tm_deref (tm_loc 0)) tm_unit / [subst r (tm_loc 0) loop_fun].
      Proof with eauto.
        unfold loop.
        reduce.
      Qed.

      Lemma loop_fun_step_self:
        tm_app (tm_deref (tm_loc 0)) tm_unit / [subst r (tm_loc 0) loop_fun] ==>+
               tm_app (tm_deref (tm_loc 0)) tm_unit / [subst r (tm_loc 0) loop_fun].
      Proof with eauto.
        unfold loop_fun; simpl.
        eapply sc_step. apply ST_App1...
        eapply sc_one. compute. apply ST_AppAbs...
      Qed.

    End RefsAndNontermination.
End STLCRef.