Require Import Utf8. (* for utf8 math symbols *)
Require Import Program.Equality. (* for the dependent induction tactic *)


(* Introduce convenient notations for partial functions and fixed points: *)

(* partial functions *)
Definition pfunc (A B:Type) := A -> option B.
Bind Scope pfunc_scope with pfunc.
Open Scope pfunc_scope.
Notation "x ⇀ y" := (pfunc x y) (at level 99, y at level 200, right associativity): type_scope.

(* the empty function (bottom) *)
Notation "⊥" := (fun _ => None).

(* composition of partial functions *)
Definition pcompose {A:Type} (f g : A ⇀ A) (x : A) :=
  match g x with None => None | Some y => f y end.
Notation "f ○ g" := (pcompose f g) (at level 40, g at next level, left associativity) : pfunc_scope.

(* iterative composition of partial functions *)
Fixpoint ncompose {A} (f: A -> A) n a :=
  match n with O => a | S m => f (ncompose f m a) end.
Notation "f ^ n" := (ncompose f n): pfunc_scope.

(* preorder relation for partial functions (i.e., subset) *)
Definition psubset {A B:Type} (f g : A ⇀ B) : Prop :=
  ∀ x y, f x = Some y -> g x = Some y.
Notation "f ⊆ g" := (psubset f g) (at level 70, g at next level, right associativity) : pfunc_scope.

(* F has the "ωchain" property iff its Kleene chain is an omega chain *)
Definition ωchain {A B:Type} (F : (A ⇀ B) -> (A ⇀ B)) := ∀ n, (F^n) ⊥ ⊆ (F^(S n)) ⊥.

(* We here introduce an opaque combinator Fix, which will denote the least fixed point
   of its argument functional.  (To avoid any unsoundness, we introduce its type signature
   as a theorem, with a proof that it is inhabited.) *)
Theorem Fix : ∀ {A B:Set}, ((A ⇀ B) -> (A ⇀ B)) -> (A ⇀ B).
Proof. unfold pfunc. intros. exact None. Qed.

(* We then assign meaning to Fix by introducing the Axiom of Union from set theory,
   specialized to only those functionals over Set that have the ωchain property.
   Thus, "Fix F" is defined to be the infinite union of F's Kleene chain. *)
Axiom inf_union:
  ∀ {A B:Set} (F: (A ⇀ B) -> (A ⇀ B)) (CH: ωchain F) x y,
  Fix F x = Some y <-> ∃ n, (F^n) ⊥ x = Some y.

(* It's also useful to have a lemma proving the contrapositive of the Axiom of Union. *)
Lemma cp_inf_union:
  ∀ {A B:Set} (F: (A ⇀ B) -> (A ⇀ B)) (CH: ωchain F) x,
  Fix F x = None <-> ∀ n, (F^n) ⊥ x = None.
Proof.
  intros. split; intros.
    destruct ((F^n) ⊥ x) eqn:H1.
      rewrite <- H. symmetry. apply inf_union. exact CH. exists n. exact H1.
      reflexivity.
    destruct (Fix F x) eqn:H1.
      apply inf_union in H1. destruct H1 as [n H1]. rewrite <- H1. apply H. exact CH.
      reflexivity.
Qed.




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

Module SemanticEquivalence.

(* 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.
   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.
Definition store : Set := var -> int.

(* To obtain more general proofs, I have generalized the cases for arithmetic operations (Aop),
   comparisons (Cmp), and boolean operations (Bop) below to encode arbitrary functions (f).
   To support short-circuited semantics of boolean operations, I've parameterized those with a
   partial function that, if defined for the result of evaluating the first argument, stops
   and returns its result early. *)

Inductive aexp: Type :=
  | Num (n:int)
  | Var (v:var)
  | Aop (f:int->int->int) (a1:aexp) (a2:aexp).

Inductive bexp: Type :=
  | Bool (b:bool)
  | Cmp (f:int->int->bool) (a1:aexp) (a2:aexp)
  | Bop (f:bool ⇀ bool) (b1:bexp) (b2:bexp).

(* Commands *)
Inductive cmd: Type :=
  | Skip
  | Seq (c1:cmd) (c2:cmd)
  | Assign (v:var) (a:aexp)
  | Cond (b:bexp) (c1:cmd) (c2:cmd)
  | While (b:bexp) (c:cmd).



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

Definition update {A:Type} (f:var->A) (x:var) (y:A) (z:var) :=
  if (vareq z x) then y else f z.

Inductive conv_aexp : (aexp * store) -> int -> Prop :=
  | LO_Num (s:store) (n:int):
           conv_aexp (Num n, s) n
  | LO_Var (s:store) (v:var) (n:int) (SVN: s v = n):
           conv_aexp (Var v, s) n
  | LO_Aop (s:store) (f:int->int->int) (a1 a2:aexp) (n1 n2:int)
           (CA1: conv_aexp (a1, s) n1) (CA2: conv_aexp (a2, s) n2):
           conv_aexp (Aop f a1 a2, s) (f n1 n2).

Inductive conv_bexp : (bexp * store) -> bool -> Prop :=
  | LO_Bool (s:store) (b:bool):
            conv_bexp (Bool b, s) b
  | LO_Cmp (s:store) (f:int->int->bool) (a1 a2:aexp) (n1 n2:int)
           (CA1: conv_aexp (a1, s) n1) (CA2: conv_aexp (a2, s) n2):
           conv_bexp (Cmp f a1 a2, s) (f n1 n2)
  | LO_Bop (s:store) (f:bool ⇀ bool) (b1 b2:bexp) (p1 p2:bool)
           (CB1: conv_bexp (b1, s) p1) (CB2: conv_bexp (b2, s) p2):
           conv_bexp (Bop f b1 b2, s) (match f p1 with None => p2 | Some p' => p' end).

Inductive conv_cmd : (cmd * store) -> store -> Prop :=
  | LO_Skip (s:store):
            conv_cmd (Skip, s) s
  | LO_Seq (s s2 s':store) (c1 c2:cmd)
           (CC1: conv_cmd (c1, s) s2) (CC2: conv_cmd (c2, s2) s'):
           conv_cmd (Seq c1 c2, s) s'
  | LO_Assign (s:store) (v:var) (a:aexp) (n:int)
              (CA: conv_aexp (a, s) n):
              conv_cmd (Assign v a, s) (update s v n)
  | LO_Cond (s s':store) (b:bexp) (c1 c2:cmd) (p:bool)
            (CB: conv_bexp (b, s) p) (CC: conv_cmd ((if p then c1 else c2), s) s'):
            conv_cmd (Cond b c1 c2, s) s'
  | LO_While (s s':store) (b:bexp) (c:cmd)
             (CC: conv_cmd (Cond b (Seq c (While b c)) Skip, s) s'):
             conv_cmd (While b c, s) s'.

Notation "x ⇓ᵃ n" := (conv_aexp x n) (at level 90, n at next level, no associativity).
Notation "x ⇓ᵇ p" := (conv_bexp x p) (at level 90, p at next level, no associativity).
Notation "x ⇓ᶜ s'" := (conv_cmd x s') (at level 90, s' at next level, no associativity).


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

Inductive step_aexp : (aexp * store) -> (aexp * store) -> Prop :=
  | SO_Var (s:store) (v:var) (n:int) (SVN: s v = n):
           step_aexp (Var v, s) (Num n, s)

  | SO_Aop1 (s s':store) (a1 a1' a2:aexp) (f:int->int->int)
            (SPa: step_aexp (a1, s) (a1', s')):
            step_aexp (Aop f a1 a2, s) (Aop f a1' a2, s')
  | SO_Aop2 (s s':store) (n:int) (a2 a2':aexp) (f:int->int->int)
            (SPb: step_aexp (a2, s) (a2', s')):
            step_aexp (Aop f (Num n) a2, s) (Aop f (Num n) a2', s')
  | SO_Aop3 (n1 n2:int) (s:store) (f:int->int->int):
            step_aexp (Aop f (Num n1) (Num n2), s) (Num (f n1 n2), s).

Inductive step_bexp : (bexp * store) -> (bexp * store) -> Prop :=
  | SO_Cmp1 (s s':store) (a1 a1' a2:aexp) (f:int->int->bool)
            (SLa: step_aexp (a1, s) (a1', s')):
            step_bexp (Cmp f a1 a2, s) (Cmp f a1' a2, s')
  | SO_Cmp2 (s s':store) (n:int) (a2 a2':aexp) (f:int->int->bool)
            (SLb: step_aexp (a2, s) (a2', s')):
            step_bexp (Cmp f (Num n) a2, s) (Cmp f (Num n) a2', s')
  | SO_Cmp3 (n1 n2:int) (s: store) (f:int->int->bool):
            step_bexp (Cmp f (Num n1) (Num n2), s) (Bool (f n1 n2), s)

  | SO_Bop1 (s s':store) (b1 b1' b2:bexp) (f:bool ⇀ bool)
            (SAa: step_bexp (b1, s) (b1', s')):
            step_bexp (Bop f b1 b2, s) (Bop f b1' b2, s')
  | SO_Bop2 (b2:bexp) (s:store) (p1:bool) (f:bool ⇀ bool):
            step_bexp (Bop f (Bool p1) b2, s) (match f p1 with None => b2
                                                             | Some p' => Bool p' end, s).

Inductive step_cmd : (cmd * store) -> (cmd * store) -> Prop :=
  | SO_Seq (s s':store) (c1 c2 c1':cmd)
           (SC: step_cmd (c1, s) (c1', s')):
           step_cmd (Seq c1 c2, s) (Seq c1' c2, s')
  | SO_Seq_Skip (s:store) (c:cmd):
                step_cmd (Seq Skip c, s) (c, s)

  | SO_Assign (s s':store) (v:var) (a a':aexp)
              (SA: step_aexp (a, s) (a', s')):
              step_cmd (Assign v a, s) (Assign v a', s')
  | SO_Assign_Num (s:store) (v:var) (n:int):
                  step_cmd (Assign v (Num n), s) (Skip, update s v n)

  | SO_Cond (s s':store) (b b':bexp) (c1 c2:cmd)
            (SB: step_bexp (b, s) (b', s')):
            step_cmd (Cond b c1 c2, s) (Cond b' c1 c2, s')
  | SO_Cond_TF (s:store) (c1 c2:cmd) (b:bool):
               step_cmd (Cond (Bool b) c1 c2, s) ((if b then c1 else c2), s)

  | SO_While (s:store) (b:bexp) (c:cmd): (* 27 *)
             step_cmd (While b c, s) (Cond b (Seq c (While b c)) Skip, s).

Notation "x ᵃ->₁ x'" := (step_aexp x x') (at level 90, x' at next level, no associativity).
Notation "x ᵇ->₁ x'" := (step_bexp x x') (at level 90, x' at next level, no associativity).
Notation "x ᶜ->₁ x'" := (step_cmd x x') (at level 90, 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 (x1 x2 x':A) (i:nat)     (* i>0 steps *)
             (Hfst: R x1 x2) (Hrst: rtclosure R i x2 x'):
             rtclosure R (S i) x1 x'.

Notation "x ᵃ->{ n  } x'" := (rtclosure step_aexp n x x') (at level 90, x' at next level, no associativity).
Notation "x ᵇ->{ n  } x'" := (rtclosure step_bexp n x x') (at level 90, x' at next level, no associativity).
Notation "x ᶜ->{ n  } x'" := (rtclosure step_cmd n x x') (at level 90, x' at next level, no associativity).



(***
 *** Denotational Semantics of SIMPL
 ***)

Fixpoint eval_aexp (a:aexp) (s:store) : int :=
  match a with
  | Num n => n
  | Var v => s v
  | Aop f a1 a2 => f (eval_aexp a1 s) (eval_aexp a2 s)
  end.

Fixpoint eval_bexp (b:bexp) (s:store) : bool :=
  match b with
  | Bool b => b
  | Cmp f a1 a2 => f (eval_aexp a1 s) (eval_aexp a2 s)
  | Bop f b1 b2 => match f (eval_bexp b1 s) with None => eval_bexp b2 s | Some p' => p' end
  end.

Definition Γ (eb : store -> bool) (ec : store ⇀ store)
             (f : store ⇀ store) (s : store) :=
  if eb s then (f ○ ec) s else Some s.

Fixpoint exec_cmd (c:cmd) : store ⇀ store :=
  match c with
  | Skip => (fun s => Some s)
  | Seq c1 c2 => (exec_cmd c2) ○ (exec_cmd c1)
  | Assign v a => (fun s => Some (update s v (eval_aexp a s)))
  | Cond b c1 c2 => (fun s => exec_cmd (if eval_bexp b s then c1 else c2) s)
  | While b c1 => Fix (Γ (eval_bexp b) (exec_cmd c1))
  end.

Notation "A〚 a 〛" := (eval_aexp a) (at level 200, left associativity).
Notation "B〚 b 〛" := (eval_bexp b) (at level 200, left associativity).
Notation "C〚 c 〛" := (exec_cmd c) (at level 200, left associativity).



(***
 *** Proof of Semantic Equivalence for SIMPL
 ***
 *** Theorem: The following three statements are equivalent:
 ***   (1) <c,s> ⇓ s'
 ***   (2) <c,s> ->* <Skip,s'>
 ***   (3) C〚 c 〛s = s'
 ***)


(* First we set up some machinery for fixed point induction proofs... *)

(* Define a fixed point induction principle for proving properties of the form:
      ∀ input-output pairs (x,y) in Fix(F), <some property of (x,y)> *)
Definition fixpoint_ind_principle {A B:Set} (F: (A ⇀ B) -> (A ⇀ B)) :=
  ∀ (P: A -> B -> Prop)
    (IC: ∀ (g: A ⇀ B) (IH: ∀ x y, g x = Some y -> P x y) x y, F g x = Some y -> P x y),
  ∀ x y, Fix F x = Some y -> P x y.

(* Prove that the fixed point induction principle defined above can be applied
   to any functional F that forms an ωchain. *)
Theorem fixpoint_induction:
  ∀ {A B:Set} (F: (A ⇀ B) -> (A ⇀ B)) (CH: ωchain F),
  fixpoint_ind_principle F.
Proof.
  unfold fixpoint_ind_principle. intros. apply inf_union in H.
    destruct H as [n NC]. revert x y NC. induction n; intros.
      discriminate.
      simpl in NC. apply IC in NC.
        exact NC.
        intros x2 y2 NC2. apply IHn. exact NC2.
    exact CH.
Qed.

(* Gamma forms an ωchain. *)
Lemma Gamma_chain: ∀ eb ec, ωchain (Γ eb ec).
Proof.
  intros. cut (forall f g, psubset f g -> psubset (Γ eb ec f) (Γ eb ec g)).
    intros M n. induction n; intros x y H.
      discriminate.
      eapply M. exact IHn. exact H.
    intros f g SS s s'. unfold Γ,pcompose. destruct (eb s).
      destruct (ec s).
        apply SS.
        discriminate.
      trivial.
Qed.

(* Since Gamma forms an ωchain, we can do fixed point induction on it. *)
Theorem fixpoint_induction_Gamma: ∀ eb ec, fixpoint_ind_principle (Γ eb ec).
Proof. intros. apply fixpoint_induction. apply Gamma_chain. Qed.




(* All the small-step rules that 1-step a sub-expression can be extended to n-steps:
         x ->₁x'                   x ->n x'
     ----------------   ====>   ----------------
     op(x) ->₁op(x')            op(x) ->n op(x')

   (Technical note:  The lemmas below could be better conslidated using Evaluation
   Contexts; but we haven't covered those in class yet, so I prove them in batch
   using an Ltac macro below.)
 *)

Definition nstep_subexp {A B:Type}
    (R1: (A * store) -> (A * store) -> Prop)
    (R2: (B * store) -> (B * store) -> Prop) (op: B -> A) : Prop :=
  ∀ i x x' s s', rtclosure R2 i (x, s) (x',s') -> rtclosure R1 i (op x, s) (op x', s').

Ltac prove_reduce_subexp T :=
  let i:=fresh in let H:=fresh in let IH:=fresh in
  intros; intro i; (induction i as [|? IH]; intros ? ? ? ? H; inversion H as [|? (?,?)]; subst);
  [ apply RTC_Refl
  | eapply RTC_Step;
    [ eapply T; eassumption
    | apply IH; eassumption ] ].

Lemma nstep_aop1: ∀ f a2, nstep_subexp step_aexp step_aexp (fun a1 => Aop f a1 a2).
Proof. prove_reduce_subexp SO_Aop1. Qed.

Lemma nstep_aop2: ∀ f n, nstep_subexp step_aexp step_aexp (Aop f (Num n)).
Proof. prove_reduce_subexp SO_Aop2. Qed.

Lemma nstep_cmp1: ∀ f a2, nstep_subexp step_bexp step_aexp (fun a1 => Cmp f a1 a2).
Proof. prove_reduce_subexp SO_Cmp1. Qed.

Lemma nstep_cmp2: ∀ f n, nstep_subexp step_bexp step_aexp (Cmp f (Num n)).
Proof. prove_reduce_subexp SO_Cmp2. Qed.

Lemma nstep_bop1: ∀ f b2, nstep_subexp step_bexp step_bexp (fun b1 => Bop f b1 b2).
Proof. prove_reduce_subexp SO_Bop1. Qed.

Lemma nstep_seq1: ∀ c2, nstep_subexp step_cmd step_cmd (fun c1 => Seq c1 c2).
Proof. prove_reduce_subexp SO_Seq. Qed.

Lemma nstep_assign: ∀ v, nstep_subexp step_cmd step_aexp (Assign v).
Proof. prove_reduce_subexp SO_Assign. Qed.

Lemma nstep_cond: ∀ c1 c2, nstep_subexp step_cmd step_bexp (fun b => Cond b c1 c2).
Proof. prove_reduce_subexp SO_Cond. Qed.

(* Prove that rtclosure is transitively closed. *)
Lemma rtc_split:
  ∀ (A:Type) R i j (x1 x' x'':A),
  rtclosure R i x1 x' -> rtclosure R j x' x'' -> rtclosure R (i+j) x1 x''.
Proof.
  induction i; intros.
    inversion H; subst. assumption.
    inversion H; subst. simpl. eapply RTC_Step.
      exact Hfst.
      eapply IHi. exact Hrst. exact H0.
Qed.




(* Part I: "LO_imp_SO" (1) => (2)
 *   large-step convergence implies small-step convergence *)

Theorem aexp_LO_imp_SO:
  ∀ a s n, (a,s) ⇓ᵃ n -> ∃ i, (a,s) ᵃ->{i} (Num n, s).
Proof.
  intros. dependent induction H.

  (* Num *)
  exists 0. apply RTC_Refl.

  (* Var *)
  exists 1. eapply RTC_Step.
    apply SO_Var. reflexivity.
    apply RTC_Refl.

  (* Aop *)
  specialize (IHconv_aexp1 a1 s eq_refl). destruct IHconv_aexp1 as [i IH1].
  specialize (IHconv_aexp2 a2 s eq_refl). destruct IHconv_aexp2 as [j IH2].
  exists (i+(j+1)). eapply rtc_split.
    apply nstep_aop1. exact IH1.
    eapply rtc_split.
      apply nstep_aop2. exact IH2.
      eapply RTC_Step.
        apply SO_Aop3.
        apply RTC_Refl.
Qed.

Theorem bexp_LO_imp_SO:
  ∀ b s p, (b,s) ⇓ᵇ p -> ∃ i, (b,s) ᵇ->{i} (Bool p, s).
Proof.
  intros. dependent induction H.

  (* Bool *)
  exists 0. apply RTC_Refl.

  (* Cmp *)
  apply aexp_LO_imp_SO in CA1. destruct CA1 as [i SA1].
  apply aexp_LO_imp_SO in CA2. destruct CA2 as [j SA2].
  exists (i+(j+1)). eapply rtc_split.
    apply nstep_cmp1. exact SA1.
    eapply rtc_split.
      apply nstep_cmp2. exact SA2.
      eapply RTC_Step. eapply SO_Cmp3. apply RTC_Refl.

  (* Bop *)
  specialize (IHconv_bexp1 b1 s eq_refl). destruct IHconv_bexp1 as [i IH1].
  specialize (IHconv_bexp2 b2 s eq_refl). destruct IHconv_bexp2 as [j IH2].
  exists (i + S (match f p1 with None => j | _ => 0 end)). eapply rtc_split.
    apply nstep_bop1. exact IH1.
    eapply RTC_Step. apply SO_Bop2. destruct (f p1).
      apply RTC_Refl.
      apply IH2.
Qed.

Theorem cmd_LO_imp_SO:
  ∀ c s s', (c,s) ⇓ᶜ s' -> ∃ i, (c,s) ᶜ->{i} (Skip, s').
Proof.
  intros. dependent induction H.

  (* Skip *)
  exists 0. apply RTC_Refl.

  (* Seq *)
  specialize (IHconv_cmd1 c1 s eq_refl). destruct IHconv_cmd1 as [i IH1].
  specialize (IHconv_cmd2 c2 s2 eq_refl). destruct IHconv_cmd2 as [j IH2].
  exists (i+(S j)). eapply rtc_split.
    apply nstep_seq1. exact IH1.
    eapply RTC_Step. apply SO_Seq_Skip. exact IH2.

  (* Assign *)
  apply aexp_LO_imp_SO in CA. destruct CA as [i SA].
  exists (i+1). eapply rtc_split.
    apply nstep_assign. exact SA.
    eapply RTC_Step. apply SO_Assign_Num. apply RTC_Refl.

  (* Cond *)
  apply bexp_LO_imp_SO in CB. destruct CB as [i SB].
  specialize (IHconv_cmd (if p then c1 else c2) s eq_refl). destruct IHconv_cmd as [j IH].
  exists (i+(S j)). eapply rtc_split.
    apply nstep_cond. exact SB.
    eapply RTC_Step. apply SO_Cond_TF. exact IH.

  (* While *)
  specialize (IHconv_cmd (Cond b (Seq c0 (While b c0)) Skip) s eq_refl). destruct IHconv_cmd as [i IH].
  exists (S i). eapply RTC_Step.
    apply SO_While.
    assumption.
Qed.



(* Part II: "SO_imp_DS" (2) => (3)
     small-step convergence implies denotational convergence *)

(* We first prove that all small-steps are "pure" (i.e., they never change the store). *)

Lemma aexp_step_pure:
  ∀ a a' s s', (a,s) ᵃ->₁(a',s') -> s=s'.
Proof.
  intros. dependent induction H.
    reflexivity.
    eapply IHstep_aexp. reflexivity. reflexivity.
    eapply IHstep_aexp. reflexivity. reflexivity.
    reflexivity.
Qed.

Lemma bexp_step_pure:
  ∀ b b' s s', (b,s) ᵇ->₁(b',s') -> s=s'.
Proof.
  intros. dependent induction H.
    apply aexp_step_pure in SLa. exact SLa.
    apply aexp_step_pure in SLb. exact SLb.
    reflexivity.
    eapply IHstep_bexp. reflexivity. reflexivity.
    reflexivity.
Qed.

(* As in class, we next prove that each small-step preserves the denotation. *)

Lemma aexp_step_pres:
  ∀ a a' s s', (a,s) ᵃ->₁(a',s') -> A〚a〛s = A〚a'〛s'.
Proof.
  intros. replace s' with s in *. clear s'. dependent induction H; simpl.
    reflexivity.
    rewrite (IHstep_aexp a1 a1' s); reflexivity.
    rewrite (IHstep_aexp a2 a2' s); reflexivity.
    reflexivity.
  revert H. apply aexp_step_pure.
Qed.

Lemma bexp_step_pres:
  ∀ b b' s s', (b,s) ᵇ->₁(b',s') -> B〚b〛s = B〚b'〛s'.
Proof.
  intros. replace s' with s in *. clear s'. dependent induction H; simpl.
    apply aexp_step_pres in SLa. rewrite SLa. reflexivity.
    apply aexp_step_pres in SLb. rewrite SLb. reflexivity.
    reflexivity.
    rewrite (IHstep_bexp b1 b1' s); reflexivity.
    destruct (f p1); reflexivity.
  revert H. apply bexp_step_pure.
Qed.

Theorem cmd_step_pres:
  ∀ c c2 s s2, (c,s) ᶜ->₁(c2,s2) -> C〚c〛s = C〚c2〛s2.
Proof.
  intros. dependent induction H; simpl.

  (* Seq c1 c2 --> Seq c1' cs *)
  rename c0 into c2. specialize (IHstep_cmd c1 c1' s s2 eq_refl eq_refl).
  unfold pcompose. rewrite IHstep_cmd. reflexivity.

  (* Seq Skip c2 --> c2 *)
  reflexivity.

  (* v:=a --> v:=a' *)
  rewrite aexp_step_pres with (a':=a') (s':=s2) by exact SA.
  replace s2 with s.
    reflexivity.
    revert SA. apply aexp_step_pure.

  (* v:=n --> Skip *)
  reflexivity.

  (* Cond b c1 c2 --> Cond b' c1 c2 *)
  rewrite bexp_step_pres with (b':=b') (s':=s2) by exact SB.
  replace s2 with s.
    reflexivity.
    revert SB. apply bexp_step_pure.

  (* Cond (Bool p) c1 c2 --> ci *)
  reflexivity.

  (* While b c --> Cond b (Seq c (While b c)) Skip *)
  rename s2 into s. rename c0 into c.
  destruct (C〚if B〚b〛s then Seq c (While b c) else Skip〛s) eqn:H.
    apply inf_union. apply Gamma_chain. destruct (B〚b〛s) eqn:Bs.
      simpl in H. unfold pcompose in H. destruct (C〚c〛s) eqn:Cs.
        apply inf_union in H. destruct H as [n H]. exists (S n). simpl. unfold Γ at 1. unfold pcompose. rewrite Bs,Cs. exact H. apply Gamma_chain.
        discriminate.
      exists 1. simpl. unfold Γ. rewrite Bs. exact H.
    apply cp_inf_union. apply Gamma_chain. intro n. destruct n.
      reflexivity.
      simpl. unfold Γ at 1. destruct (B〚b〛s).
        simpl in H. unfold pcompose in *. destruct (C〚c〛s).
          apply cp_inf_union. apply Gamma_chain. exact H.
          reflexivity.
        exact H.
Qed.

Theorem aexp_SO_imp_DS:
  ∀ a s s' n i, (a,s) ᵃ->{i} (Num n, s') -> A〚a〛s = n.
Proof.
  intros. change n with (A〚Num n〛s'). revert a s H. induction i; intros.
    inversion H; subst. reflexivity.
    inversion H; subst. destruct x2 as (a2,s2). transitivity (A〚a2〛s2).
      apply aexp_step_pres. exact Hfst.
      apply IHi. exact Hrst.
Qed.

Theorem bexp_SO_imp_DS:
  ∀ b s s' p i, (b,s) ᵇ->{i} (Bool p, s') -> B〚b〛s = p.
Proof.
  intros. change p with (B〚Bool p〛s'). revert b s H. induction i; intros.
    inversion H; subst. reflexivity.
    inversion H; subst. destruct x2 as (b2,s2). transitivity (B〚b2〛s2).
      apply bexp_step_pres. exact Hfst.
      apply IHi. exact Hrst.
Qed.

Theorem cmd_SO_imp_DS:
  ∀ c s s' i, (c,s) ᶜ->{i} (Skip, s') -> C〚c〛s = Some s'.
Proof.
  intros. change (Some s') with (C〚Skip〛s'). revert c s H. induction i; intros.
    inversion H; subst. reflexivity.
    inversion H; subst. destruct x2 as (c2,s2). transitivity (C〚c2〛s2).
      apply cmd_step_pres. exact Hfst.
      apply IHi. exact Hrst.
Qed.


(* Part III: "DS_imp_LO" (3) => (1)
     denotational convergence implies large-step convergence *)

Theorem aexp_DS_imp_LO:
  ∀ a s, (a,s) ⇓ᵃ A〚a〛s.
Proof.
  induction a; intros.
    (* Num *) apply LO_Num.
    (* Var *) apply LO_Var. reflexivity.
    (* Aop *) simpl. apply LO_Aop. apply IHa1. apply IHa2.
Qed.

Theorem bexp_DS_imp_LO:
  ∀ b s, (b,s) ⇓ᵇ B〚b〛s.
Proof.
  induction b; intros.
    (* Bool *) apply LO_Bool.
    (* Cmp *)  simpl. apply LO_Cmp. apply aexp_DS_imp_LO. apply aexp_DS_imp_LO.
    (* Bop *)  simpl. apply LO_Bop. apply IHb1. apply IHb2.
Qed.

Theorem cmd_DS_imp_LO:
  ∀ c s s', C〚c〛s = Some s' -> (c,s) ⇓ᶜ s'.
Proof.
  induction c; intros; simpl in H.

  (* Skip *)
  injection H; intros; subst. apply LO_Skip.

  (* Seq *)
  unfold pcompose in H.
  specialize (IHc1 s). destruct (exec_cmd c1 s); [|discriminate].
  apply LO_Seq with (s2:=s0).
    apply IHc1. reflexivity.
    apply IHc2. assumption.

  (* Assign *)
  injection H; intros; subst.
  apply LO_Assign. apply aexp_DS_imp_LO.

  (* Cond *)
  apply LO_Cond with (p:=eval_bexp b s).
    apply bexp_DS_imp_LO.
    destruct (eval_bexp b s).
      apply IHc1. assumption.
      apply IHc2. assumption.

  (* While *)
  revert s s' H. apply fixpoint_induction_Gamma; intros.
    unfold Γ in H. apply LO_While. apply LO_Cond with (p:=eval_bexp b x). apply bexp_DS_imp_LO. destruct (eval_bexp b x).
      unfold pcompose in H. specialize (IHc x). destruct (exec_cmd c x); [|discriminate]. apply LO_Seq with (s2:=s).
        apply IHc. reflexivity.
        apply IH. assumption.
      injection H; intro; subst. apply LO_Skip.
Qed.

End SemanticEquivalence.