Require Import Utf8. (* for utf8 math symbols *)
Require Import Program.Equality. (* for the dependent induction tactic *)
Require Setoid. (* for adding new reflexive, transitive relations *)
Require Import Coq.Lists.List. (* for encoding stacks of typing contexts *)
Import ListNotations.
Open Scope list_scope.


(***
 *** Syntax of SIMPL
 ***)

(* Program variables are represented abstractly as an arbitrary Set for which there is an
   equality decision procedure. *)
Parameter var : Set.
Parameter vareq : ∀ (v1 v2:var), {v1=v2}+{v1≠v2}.

(* Stores are mappings from program variables to values, where values are integers or
   bools.  Integers are represented abstractly as a datatype implemented by the underlying
   machine.  The proofs do not depend on this underlying representation, so it is here
   left unspecified via an axiom. *)
Parameter int : Set.
Inductive value := Num (n:int) | Bool (b:bool).
Definition store : Set := var -> option value.
Notation "⊥" := (fun _ => None).

(* To obtain more general proofs, I have generalized the cases for arithmetic,
   boolean, and comparison operations (Aop, Bop, and Cmp) in terms of function
   parameters f, which encode the underlying mathematical operation performed
   by each. *)

Inductive exp :=
| Const (u:value)
| Var (v:var)
| Aop (f:int->int->int) (e1 e2:exp)
| Bop (f:bool->bool->bool) (e1 e2:exp)
| Cmp (f:int->int->bool) (e1 e2:exp).

Inductive typ := TInt | TBool.

Inductive cmd :=
| Skip
| Decl (t:typ) (v:var)
| Seq (c1 c2:cmd)
| Assign (v:var) (e:exp)
| Cond (e:exp) (c1 c2:cmd)
| While (e:exp) (c:cmd)
| Scope (c:cmd).



(***
 *** Small-step Operational Semantics of SIMPL
 ***)

Definition update {A} f x (y:A) x' := if vareq x' x then Some y else f x'.

Inductive step_exp : (exp * store) -> (exp * store) -> Prop :=
| SO_Var' σ v u
    (SV: σ v = Some u):
  step_exp (Var v, σ) (Const u, σ)

| SO_Aop' f n1 n2 σ:
  step_exp (Aop f (Const (Num n1)) (Const (Num n2)), σ) (Const (Num (f n1 n2)), σ)

| SO_Aop2 f σ σ' u e2 e2'
    (SPb: step_exp (e2, σ) (e2', σ')):
  step_exp (Aop f (Const u) e2, σ) (Aop f (Const u) e2', σ')

| SO_Aop1 f σ σ' e1 e1' e2
    (SPa: step_exp (e1, σ) (e1', σ')):
  step_exp (Aop f e1 e2, σ) (Aop f e1' e2, σ')

| SO_Bop' f σ p1 p2:
  step_exp (Bop f (Const (Bool p1)) (Const (Bool p2)), σ) (Const (Bool (f p1 p2)), σ)

| SO_Bop2 f σ σ' u e2 e2'
    (SPb: step_exp (e2, σ) (e2', σ')):
  step_exp (Bop f (Const u) e2, σ) (Bop f (Const u) e2', σ')

| SO_BopShort f σ p1 p' e2
    (SH: ∀ p2, f p1 p2 = p'):
  step_exp (Bop f (Const (Bool p1)) e2, σ) (Const (Bool p'), σ)

| SO_Bop1 f σ σ' e1 e1' e2
    (SPa: step_exp (e1, σ) (e1', σ')):
  step_exp (Bop f e1 e2, σ) (Bop f e1' e2, σ')

| SO_Cmp' f σ n1 n2:
  step_exp (Cmp f (Const (Num n1)) (Const (Num n2)), σ) (Const (Bool (f n1 n2)), σ)

| SO_Cmp2 f σ σ' u e2 e2'
    (SPb: step_exp (e2, σ) (e2', σ')):
  step_exp (Cmp f (Const u) e2, σ) (Cmp f (Const u) e2', σ')

| SO_Cmp1 f σ σ' e1 e1' e2
    (SPa: step_exp (e1, σ) (e1', σ')):
  step_exp (Cmp f e1 e2, σ) (Cmp f e1' e2, σ').

Inductive step_cmd : (cmd * store) -> (cmd * store) -> Prop :=
| SO_Decl σ t v:
  step_cmd (Decl t v, σ) (Skip, σ)

| SO_SeqSkip σ c:
  step_cmd (Seq Skip c, σ) (c, σ)

| SO_Seq σ σ' c1 c2 c1'
    (SC: step_cmd (c1, σ) (c1', σ')):
  step_cmd (Seq c1 c2, σ) (Seq c1' c2, σ')

| SO_Assign' σ v u:
  step_cmd (Assign v (Const u), σ) (Skip, update σ v u)

| SO_Assign σ σ' v e e'
    (SE: step_exp (e, σ) (e', σ')):
  step_cmd (Assign v e, σ) (Assign v e', σ')

| SO_Cond' σ c1 c2 p:
  step_cmd (Cond (Const (Bool p)) c1 c2, σ) (Scope (if p then c1 else c2), σ)

| SO_Cond σ σ' e e' c1 c2
    (SB: step_exp (e, σ) (e', σ')):
  step_cmd (Cond e c1 c2, σ) (Cond e' c1 c2, σ')

| SO_While σ e c:
  step_cmd (While e c, σ) (Cond e (Seq (Scope c) (While e c)) Skip, σ)

| SO_Scope' σ:
  step_cmd (Scope Skip, σ) (Skip, σ)

| SO_Scope σ σ' c c'
    (SC: step_cmd (c,σ) (c',σ')):
  step_cmd (Scope c, σ) (Scope c', σ').

Notation "x ᵉ->₁ x'" := (step_exp x x') (at level 70, x' at next level, no associativity).
Notation "x ᶜ->₁ x'" := (step_cmd x x') (at level 70, x' at next level, no associativity).

(* Define the reflexive, transitive closure of a small-step relation: *)
Inductive rtclosure {A:Type} (R: A -> A -> Prop): nat -> A -> A -> Prop :=
  | RTC_Refl (x:A): rtclosure R O x x (* i=0 steps *)
  | RTC_Step (x x2 x':A) (i:nat)    (* i>0 steps *)
             (Hfst: R x x2) (Hrst: rtclosure R i x2 x'):
             rtclosure R (S i) x x'.

Definition nstep_exp := rtclosure step_exp.
Definition nstep_cmd := rtclosure step_cmd.

Notation "x ᵉ->{ n  } x'" := (nstep_exp n x x') (at level 70, x' at next level, no associativity).
Notation "x ᶜ->{ n  } x'" := (nstep_cmd n x x') (at level 70, x' at next level, no associativity).


(***
 *** Static Semantics of SIMPL
 ***)

Definition tcontext : Set := var -> option (typ * bool).

Inductive typ_exp (Γ:tcontext) : exp -> typ -> Prop :=
| TE_Num n:
  typ_exp Γ (Const (Num n)) TInt

| TE_Bool p:
  typ_exp Γ (Const (Bool p)) TBool

| TE_Var v t
    (TC: Γ v = Some (t,true)):
  typ_exp Γ (Var v) t

| TE_Aop f e1 e2
    (TE1: typ_exp Γ e1 TInt) (TE2: typ_exp Γ e2 TInt):
  typ_exp Γ (Aop f e1 e2) TInt

| TE_Bop f e1 e2
    (TE1: typ_exp Γ e1 TBool) (TE2: typ_exp Γ e2 TBool):
  typ_exp Γ (Bop f e1 e2) TBool

| TE_Cmp f e1 e2
    (TE1: typ_exp Γ e1 TInt) (TE2: typ_exp Γ e2 TInt):
  typ_exp Γ (Cmp f e1 e2) TBool.

Inductive typ_cmd : list tcontext -> cmd -> tcontext -> Prop :=
| TC_Skip Γ:
  typ_cmd [Γ] Skip Γ

| TC_Decl Γ t v
    (TC: Γ v = None):
  typ_cmd [Γ] (Decl t v) (update Γ v (t,false))

| TC_Seq Γs Γ2 Γ' c1 c2
    (TC1: typ_cmd Γs c1 Γ2) (TC2: typ_cmd [Γ2] c2 Γ'):
  typ_cmd Γs (Seq c1 c2) Γ'

| TC_Assign Γ v e t p
    (TE: typ_exp Γ e t) (TC: Γ v = Some (t,p)):
  typ_cmd [Γ] (Assign v e) (update Γ v (t,true))

| TC_Cond Γ Γs Γ1 Γ2 e c1 c2
    (TE: typ_exp Γ e TBool) (TC1: typ_cmd (Γ::Γs) c1 Γ1) (TC2: typ_cmd [Γ] c2 Γ2):
  typ_cmd (Γ::Γs) (Cond e c1 c2) Γ

| TC_While Γ Γ1 e c
    (TE: typ_exp Γ e TBool) (TC1: typ_cmd [Γ] c Γ1):
  typ_cmd [Γ] (While e c) Γ

| TC_Scope Γ1 Γs Γ' c
    (TC: typ_cmd Γs c Γ'):
  typ_cmd (Γ1::Γs) (Scope c) Γ1.



(***
 *** Proof of type-safety for SIMPL
 ***)

(* Modeling relation *)
Definition models (σ:store) (Γ:tcontext) :=
  ∀ v t, Γ v = Some (t,true) ->
         match t with TInt  => ∃ n, σ v = Some (Num n)
                    | TBool => ∃ p, σ v = Some (Bool p) end.

Notation "Γ |= σ" := (models σ Γ) (at level 70, σ at next level, no associativity).

(* Subtyping *)
Definition subtyp (Γ1 Γ2: tcontext) :=
  ∀ v t p, Γ2 v = Some (t,p) ->
             ∃ q, Γ1 v = Some (t,q) /\ Bool.le p q.

Notation "Γ1 <<= Γ2" := (subtyp Γ1 Γ2) (at level 70, Γ2 at next level, no associativity).

Lemma subtyp_reflexive: ∀ Γ, Γ <<= Γ.
Proof.
  unfold subtyp. intros. exists p. split.
    assumption.
    apply Bool.le_implb, Bool.implb_same.
Qed.

Lemma subtyp_transitive:
  ∀ Γ1 Γ2 Γ3 (ST1: Γ1 <<= Γ2) (ST2: Γ2 <<= Γ3), Γ1 <<= Γ3.
Proof.
  unfold subtyp. intros.
  apply ST2 in H. destruct H as [q [H1 H2]].
  apply ST1 in H1. destruct H1 as [r [H3 H4]].
  eexists. split.
    eassumption.
    destruct p,q,r; solve [ reflexivity | discriminate ].
Qed.

Add Parametric Relation: tcontext subtyp
  reflexivity proved by subtyp_reflexive
  transitivity proved by subtyp_transitive
as subtype.

Lemma models_subtyp:
  ∀ Γ1 Γ2 σ (ST: Γ1 <<= Γ2) (M: Γ1 |= σ), Γ2 |= σ.
Proof.
  unfold models. intros. apply M.
  apply ST in H. destruct H as [[|] [H1 H2]].
    assumption.
    discriminate.
Qed.

Inductive subtyp_chain : list tcontext -> Prop :=
| SC_Single Γ:
  subtyp_chain [Γ]
| SC_Many Γ1 Γ2 Γs
    (ST: Γ2 <<= Γ1) (STC: subtyp_chain (Γ2::Γs)):
  subtyp_chain (Γ1::Γ2::Γs).

Lemma typ_exp_subtyp:
  ∀ e Γ1 Γ2 t (ST: Γ1 <<= Γ2) (TE: typ_exp Γ2 e t),
    typ_exp Γ1 e t.
Proof.
  induction e; intros; inversion TE; subst; constructor;
  try (eapply IHe1 + eapply IHe2; eassumption).
  apply ST in TC. destruct TC as [[|] [H1 H2]]. assumption. discriminate.
Qed.

Lemma typ_exp_chain:
  ∀ e t Γs Γ
  (STC: subtyp_chain (Γ::Γs)) (TE: typ_exp Γ e t),
  Forall (fun g => typ_exp g e t) (Γ::Γs).
Proof.
  induction Γs; intros.
    constructor. assumption. constructor.
    constructor. assumption. inversion STC; subst. apply IHΓs.
      assumption.
      eapply typ_exp_subtyp; eassumption.
Qed.

Lemma typcmd_nonempty_chain:
  ∀ c Γ', ~ typ_cmd nil c Γ'.
Proof.
  induction c; intros; intro H; inversion H.
  subst. eapply IHc1. eassumption.
Qed.

(* Proof of progress for expressions *)
Theorem progress_exp:
  ∀ σ {Γ e t} (TE: typ_exp Γ e t) (M: Γ |= σ),
    (∃ u, e = Const u) \/ (∃ x', (e,σ) ᵉ->₁ x').
Proof.
  intros.
  dependent induction TE.

  (* Num *)
  left. eexists. reflexivity.

  (* Bool *)
  left. eexists. reflexivity.

  (* Var *)
  right. apply M in TC. destruct t, TC; eexists; constructor; eassumption.

  (* All remaining cases proved as follows: *)
  all: right; destruct (IHTE1 M) as [[? ?]|[(?,?) ?]];
       [ subst; inversion_clear TE1; destruct (IHTE2 M) as [[? ?]|[(?,?) ?]];
         [ subst; inversion_clear TE2; eexists; constructor
         | eexists; constructor; eassumption ]
       | eexists; constructor; eassumption ].
Qed.

(* Proof of progress for commands *)
Theorem progress_cmd:
  ∀ Γs σ c Γ' (TC: typ_cmd Γs c Γ') (M: Forall (models σ) Γs),
    c = Skip \/ (∃ x', (c,σ) ᶜ->₁ x').
Proof.
  intros.
  dependent induction TC.

  (* Skip *)
  left. reflexivity.

  (* Decl *)
  right. eexists. constructor.

  (* Seq *)
  right. destruct (IHTC1 M).
    subst. eexists. constructor.
    destruct H, x. eexists. constructor. eassumption.

  (* Assign *)
  right. destruct (progress_exp σ TE). eapply Forall_inv, M.
    destruct H. subst. eexists. constructor.
    destruct H, x. eexists. constructor. eassumption.

  (* Cond *)
  right. destruct (progress_exp σ TE). eapply Forall_inv, M.
    destruct H. subst. inversion_clear TE. eexists. constructor.
    destruct H, x. eexists. constructor. eassumption.

  (* While *)
  right. eexists. constructor.

  (* Scope *)
  right. apply Forall_inv_tail in M. destruct (IHTC M).
    subst. eexists. constructor.
    destruct H, x. eexists. constructor. eassumption.
Qed.

(* Proof of preservation for expressions *)
Theorem preservation_exp:
  ∀ Γ σ1 σ2 e1 e2 t (TE: typ_exp Γ e1 t) (M: Γ |= σ1) (SE: (e1,σ1) ᵉ->₁ (e2,σ2)),
    typ_exp Γ e2 t /\ Γ |= σ2.
Proof.
  intros. revert t TE.
  dependent induction SE; intros.

  (* Var *)
  split.
    inversion_clear TE. apply M in TC. destruct t, TC;
      rewrite SV in H; inversion_clear H; constructor.
    assumption.

  (* All remaining cases proved as follows: *)
  all: inversion TE; subst; split;
       [ constructor; first [ assumption | eapply IHSE; try reflexivity; eassumption]
       | first [ assumption | eapply IHSE; try reflexivity; eassumption ] ].
Qed.

(* Proof of preservation for commands *)
Theorem preservation_cmd:
  ∀ Γ1 Γ' Γs1 σ1 σ2 c1 c2 (STC: subtyp_chain (Γ1::Γs1))
     (TC: typ_cmd (Γ1::Γs1) c1 Γ') (M: Forall (models σ1) (Γ1::Γs1)) (STEP: (c1,σ1) ᶜ->₁ (c2,σ2)),
    ∃ Γ2 Γs2, typ_cmd (Γ2::Γs2) c2 Γ' /\ Forall (models σ2) (Γ2::Γs2) /\ subtyp_chain (Γ2::Γs2) /\ Γ2 <<= Γ1.
Proof.
  intros until c2.
  set (x1 := (c1,σ1)). set (x2 := (c2,σ2)).
  change c1 with (fst x1). change σ1 with (snd x1).
  change c2 with (fst x2). change σ2 with (snd x2).
  clearbody x1 x2. clear c1 c2 σ1 σ2.
  intros. revert Γ1 Γs1 Γ' STC TC M.
  dependent induction STEP; try rename IHSTEP into IH; intros; inversion TC; subst; simpl in *.

  (* Decl *)
  eexists _,_. repeat split.
    constructor.
    constructor.
      apply Forall_inv in M. unfold models, update. intros. destruct vareq.
        discriminate.
        apply M. assumption.
      constructor.
    constructor.
    unfold subtyp, update. intros. destruct vareq.
      subst. rewrite TC0 in H. discriminate.
      eexists. split. eassumption. destruct p; reflexivity.

  (* SeqSkip *)
  inversion TC1; subst. eexists _,_. repeat split.
    eassumption.
    assumption.
    constructor.
    reflexivity.

  (* Seq *)
  destruct (IH _ _ _ STC TC1 M) as [Γ2' [Γs2' [TC2' [M2 [STC2 ST2]]]]].
  eexists _,_. repeat split; [econstructor|..]; eassumption.

  (* Assign' *)
  eexists _,nil. repeat split.
    constructor.
    constructor.
      apply Forall_inv in M. unfold models, update. intros. destruct vareq.
        inversion H; subst. destruct t0; inversion TE; subst; eexists; reflexivity.
        apply M. assumption.
      constructor.
    constructor.
    unfold subtyp, update. intros. destruct vareq.
      subst. rewrite TC0 in H. inversion H; subst. eexists. split. reflexivity. destruct p0; reflexivity.
      eexists. split. eassumption. destruct p0; reflexivity.

  (* Assign *)
  apply Forall_inv in M. eexists _,_. repeat split.
    econstructor; [|eassumption]. eapply preservation_exp; eassumption.
    constructor. eapply preservation_exp; eassumption.
    constructor.
    constructor.
    reflexivity.

  (* Cond' *)
  destruct p.
    eexists _,_. repeat split.
      econstructor. eassumption.
      constructor. eapply Forall_inv, M. assumption.
      constructor. reflexivity. assumption.
      reflexivity.
    eexists _,_. repeat split.
      econstructor. eassumption.
      constructor. eapply Forall_inv, M. constructor. eapply Forall_inv, M. constructor.
      constructor. reflexivity. constructor.
      reflexivity.

  (* Cond *)
  eexists _,_. repeat split.
    econstructor.
      eapply preservation_exp. eassumption. eapply Forall_inv, M. eassumption.
      eassumption.
      eassumption.
    apply Forall_forall. intros Γ IN. eapply preservation_exp with (e1:=e) (t:=TBool).
      pattern Γ. eapply (proj1 (Forall_forall _ _)). apply typ_exp_chain; eassumption. assumption.
      eapply Forall_forall; eassumption.
      eassumption.
    assumption.
    reflexivity.

  (* While *)
  eexists _,_. repeat split.
    econstructor.
      assumption.
      econstructor; econstructor; eassumption.
      constructor.
    constructor. eapply Forall_inv, M. constructor. eapply Forall_inv, M. constructor.
    constructor. reflexivity. constructor.
    reflexivity.

  (* ScopeSkip *)
  eexists _,nil. repeat split.
    constructor.
    constructor. eapply Forall_inv, M. constructor.
    constructor.
    reflexivity.

  (* Scope *)
  destruct Γs1 as [|Γ1' Γs1]. contradict TC0. apply typcmd_nonempty_chain.
  inversion STC. inversion M. subst.
  destruct (IH _ _ _ STC0 TC0 H5) as [Γ2' [Γs2' [TC2' [M2 [STC2 ST2]]]]].
  eexists _,_. repeat split.
    econstructor. eassumption.
    constructor.
      eapply models_subtyp. etransitivity; eassumption. eapply Forall_inv, M2.
      assumption.
    constructor. etransitivity; eassumption. assumption.
    reflexivity.
Qed.

Theorem type_safety:
  ∀ σ n σ' c c' Γ'
    (TC: typ_cmd [⊥] c Γ') (STEPS: (c,σ) ᶜ->{n} (c',σ')),
    c' = Skip \/ (∃ x'', (c',σ') ᶜ->₁ x'').
Proof.
  set (Γ := ⊥). set (Γs := nil). intros σ n.
  assert (STC: subtyp_chain (Γ::Γs)) by constructor.
  assert (M: Forall (models σ) (Γ::Γs)) by (constructor; [ discriminate | constructor ]).
  clearbody Γ Γs. revert Γ Γs σ STC M. induction n; intros; inversion STEPS; subst.
    eapply progress_cmd; eassumption.
    destruct x2 as (c2,σ2). eapply preservation_cmd in Hfst; [|eassumption..].
      destruct Hfst as [Γ2 [Γs2 [TC2 [M2 [STC2 ST2]]]]]. eapply IHn; eassumption.
Qed.