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

(*** First we prove the foundations of fixpoint theory, so that we can
     define denotational semantics within Coq's constructivistic logic. ***)

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

(* composition of partial functions *)
Definition pcompose {A B C} (f: B -> option C) (g: A -> option B) (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).

(* iterative composition of total 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).

(* preorder relation for partial functions (i.e., subset) *)
Definition psubset {A B} (f g : A -> option 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).

(* monotonicity of functionals *)
Definition monotonic {A B} (F: (A -> option B) -> (A -> option B)) :=
  ∀ f g, f ⊆ g -> F f ⊆ F g.

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

(* Monotonic functionals have the "ωchain" property. *)
Theorem mono_chain:
  ∀ {A B} (F: (A -> option B) -> (A -> option B)), monotonic F -> ωchain F.
Proof.
  unfold monotonic,ωchain. intros. induction n.
    discriminate.
    simpl. apply H. exact IHn.
Qed.

(* the subset of all functionals satisfying ωchain *)
Definition chained A B := { F : (A -> option B) -> (A -> option B) | ωchain F }.
Notation "x ⇀ y" := (chained x y) (at level 99, y at level 200, right associativity): type_scope.
Notation "! F" := (proj1_sig F) (at level 1, format "! F").

(* a convenience lemma for reasoning transitively about ωchain: *)
Lemma ωchain_le:
  ∀ {A B} (F: A ⇀ B) m n (LE: m <= n),
  (!F^m) ⊥ ⊆ (!F^n) ⊥.
Proof.
  intros. pattern n. revert n LE. apply le_ind; intros; intros x y H1.
    exact H1.
    apply (proj2_sig F). apply H0. exact H1.
Qed.

(* The axiom of union can be defined as the existence of a join operator
   over the lattice of partial functions, which we will (prophetically) call
   "Fix".  Fix may only be applied to a functional with the ωchain property,
   since otherwise the union of its Kleene chain would be a non-function. *)
Definition Fix_exists_for {A B:Set} (F: (A -> option B) -> (A -> option B)) :=
  { FixF | ∀ x y, (FixF x = Some y <-> ∃ n, (F^n) ⊥ x = Some y) }.
Definition Fix_existence :=
  ∀ (A B:Set) (F: A ⇀ B), Fix_exists_for (proj1_sig F).

(* Before admitting Fix_existence as an axiom, let's prove it sound.  We do so
   by showing that it follows from Classical Indefinite Description, which is
   known to be a sound extension to CIC. *)
Require Import ClassicalFacts.
Require Import ChoiceFacts.
Section InfiniteUnionSoundness.

  Lemma CID_CDD:
    ConstructiveIndefiniteDescription -> ConstructiveDefiniteDescription.
  Proof.
    intros CID A P H. apply CID. destruct H as [x H]. exists x. apply proj1 in H. exact H.
  Qed.

  Definition in_graph {A B:Set} (F: (A -> option B) -> (A -> option B)) x (y:option B) : Prop :=
    if y then ∃ n, (F^n) ⊥ x = y else ∀ n, (F^n) ⊥ x = None.

  Lemma in_graph_unique:
    ∀ {A B:Set} (F: A ⇀ B) x y1 y2
      (IG1: in_graph !F x y1) (IG2: in_graph !F x y2), y1 = y2.
  Proof.
    intros.
    destruct y1; destruct y2.

    destruct IG1 as [n1 IG1]. destruct IG2 as [n2 IG2].
    destruct (le_ge_dec n1 n2) as [LE|LE].
      apply (ωchain_le F n1 n2 LE) in IG1. rewrite <- IG1. exact IG2.
      apply (ωchain_le F n2 n1 LE) in IG2. rewrite <- IG1. exact IG2.

    destruct IG1 as [n IG1]. rewrite <- IG1. apply IG2.
    destruct IG2 as [n IG2]. rewrite <- IG2. symmetry. apply IG1.
    reflexivity.
  Qed.

  Lemma EMCDD_imp_IG:
    excluded_middle -> ConstructiveDefiniteDescription ->
    ∀ {A B:Set} (F: A ⇀ B), ∃ f, ∀ x, in_graph !F x (f x).
  Proof.
    intros EM CDD A B F.
    apply (constructive_definite_descr_fun_reification CDD).
    intro x. destruct (EM (∃ y n, ((proj1_sig F)^n) ⊥ x = Some y)).
      destruct H as [y H]. exists (Some y). split.
        exact H.
        intros y' IG. apply (in_graph_unique F x). exact H. exact IG.
      exists None. split.
        intro n. destruct (((proj1_sig F)^n) ⊥ x) as [b|] eqn:H1.
          exfalso. apply H. exists b,n. exact H1.
          reflexivity.
        intros y IG. apply (in_graph_unique F x).
          intro n. destruct (((proj1_sig F)^n) ⊥ x) as [b|] eqn:H1.
            exfalso. apply H. exists b,n. exact H1.
            reflexivity.
          exact IG.
  Qed.

  Theorem CaID_imp_FE:
    excluded_middle -> ConstructiveIndefiniteDescription -> Fix_existence.
  Proof.
    intros EM CID A B FCH.
    apply CID.
    destruct (EMCDD_imp_IG EM (CID_CDD CID) FCH) as [f IG]. exists f.
    intros x y. specialize (IG x). split; intro H.
      rewrite H in IG. exact IG.
      unfold in_graph in IG. destruct (f x).
        apply (in_graph_unique FCH x). exact IG. exact H.
        destruct H as [n H]. rewrite IG in H. discriminate.
  Qed.

End InfiniteUnionSoundness.

(* Having proved soundness of Fix_existence (above), we may safely introduce it as an axiom. *)
Axiom Fix_exists: Fix_existence.
Arguments Fix_exists {A B} F.

(* Using Fix_exitence, define a fixed-point operator. *)
Definition Fix {A B:Set} (F: A ⇀ B) := proj1_sig (Fix_exists F).
Definition fix_union {A B:Set} (F: A ⇀ B) x y := proj2_sig (Fix_exists F) x y.

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

(* Prove a fixed point induction principle for proving properties of the form:
      ∀ input-output pairs (x,y) in Fix(F), <some property of (x,y)> *)
Theorem fixpoint_induction {A B:Set} (F: A ⇀ B):
  ∀ (P: A -> B -> Prop)
    (IC: ∀ (g: A -> option 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.
Proof.
  intros. apply fix_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.
Qed.

(* When F is monotonic, Fix F is least among fixpoints of F. *)
Theorem least_fixpoint:
  ∀ {A B:Set} (F: A ⇀ B) (M: monotonic !F) f,
  (∀ a, !F f a = f a) -> Fix F ⊆ f.
Proof.
  unfold "⊆". intros.
  apply fix_union in H0. destruct H0 as [n H0]. revert x y H0.
  induction n; intros.
      discriminate.
      rewrite <- H. revert H0. simpl. apply M. exact IHn.
Qed.

(* Scott-continuity of functionals w.r.t. suprema of Kleene chains: *)
Definition scont {A B:Set} (F: A ⇀ B) :=
  ∀ x, (∀ n, (!F^n) ⊥ x = None) -> !F (Fix F) x = None.

(* Knaster-Tarski theorem: Fix F is a fixed point of F. *)
Theorem is_fixedpoint:
  ∀ {A B:Set} (F: A ⇀ B) (M: monotonic !F) (SC: scont F) x,
  !F (Fix F) x = Fix F x.
Proof.
  intros. destruct (Fix F x) eqn:FFx.
    apply fix_union in FFx. destruct FFx as [n Fnx]. destruct n.
      discriminate.
      apply (M ((!F^n) ⊥)).
        intros x' y' H. apply fix_union. exists n. exact H.
        exact Fnx.
    apply SC. revert FFx. apply cp_fix_union.
Qed.

(*** End of fixpoint theory setup. ***)




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

Section Simpl.

(* Program variables are represented abstractly as an arbitrary Set for which there is an
   equality decision procedure. *)
Variable var : Set.
Variable 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. *)
Variable 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 -> option 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 σ n:
    conv_aexp (Num n, σ) n

| LO_Var σ v n
       (SVN: σ v = n):
    conv_aexp (Var v, σ) n

| LO_Aop σ f a1 a2 n1 n2
    (CA1: conv_aexp (a1, σ) n1) (CA2: conv_aexp (a2, σ) n2):
           conv_aexp (Aop f a1 a2, σ) (f n1 n2).

Inductive conv_bexp : (bexp * store) -> bool -> Prop :=
| LO_Bool σ b:
    conv_bexp (Bool b, σ) b

| LO_Cmp σ f a1 a2 n1 n2
    (CA1: conv_aexp (a1, σ) n1) (CA2: conv_aexp (a2, σ) n2):
         conv_bexp (Cmp f a1 a2, σ) (f n1 n2)

| LO_Bop σ f b1 b2 p1 p2
           (CB1: conv_bexp (b1, σ) p1) (CB2: conv_bexp (b2, σ) p2):
    conv_bexp (Bop f b1 b2, σ) (match f p1 with None => p2 | Some p' => p' end).

Inductive conv_cmd : (cmd * store) -> store -> Prop :=
| LO_Skip σ:
    conv_cmd (Skip, σ) σ

| LO_Seq σ σ2 σ' c1 c2
    (CC1: conv_cmd (c1, σ) σ2) (CC2: conv_cmd (c2, σ2) σ'):
              conv_cmd (Seq c1 c2, σ) σ'

| LO_Assign σ v a n
          (CA: conv_aexp (a, σ) n):
    conv_cmd (Assign v a, σ) (update σ v n)

| LO_Cond σ σ' b c1 c2 p
    (CB: conv_bexp (b, σ) p) (CC: conv_cmd ((if p then c1 else c2), σ) σ'):
                     conv_cmd (Cond b c1 c2, σ) σ'

| LO_While σ σ' b c
    (CC: conv_cmd (Cond b (Seq c (While b c)) Skip, σ) σ'):
              conv_cmd (While b c, σ) σ'.

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


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

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

| SO_Aop1 σ σ' a1 a1' a2 f
        (SPa: step_aexp (a1, σ) (a1', σ')):
    step_aexp (Aop f a1 a2, σ) (Aop f a1' a2, σ')

| SO_Aop2 σ σ' n a2 a2' f
          (SPb: step_aexp (a2, σ) (a2', σ')):
    step_aexp (Aop f (Num n) a2, σ) (Aop f (Num n) a2', σ')

| SO_Aop3 n1 n2 σ f:
    step_aexp (Aop f (Num n1) (Num n2), σ) (Num (f n1 n2), σ).

Inductive step_bexp : (bexp * store) -> (bexp * store) -> Prop :=
| SO_Cmp1 σ σ' a1 a1' a2 f
         (SLa: step_aexp (a1, σ) (a1', σ')):
    step_bexp (Cmp f a1 a2, σ) (Cmp f a1' a2, σ')

| SO_Cmp2 σ σ' n a2 a2' f
          (SLb: step_aexp (a2, σ) (a2', σ')):
    step_bexp (Cmp f (Num n) a2, σ) (Cmp f (Num n) a2', σ')

| SO_Cmp3 n1 n2 σ f:
    step_bexp (Cmp f (Num n1) (Num n2), σ) (Bool (f n1 n2), σ)

| SO_Bop1 σ σ' b1 b1' b2 f
        (SAa: step_bexp (b1, σ) (b1', σ')):
    step_bexp (Bop f b1 b2, σ) (Bop f b1' b2, σ')

| SO_Bop2 b2 σ p1 f:
    step_bexp (Bop f (Bool p1) b2, σ) (match f p1 with None => b2
                                                     | Some p' => Bool p' end, σ).

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

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

| SO_Assign σ σ' v a a'
       (SA: step_aexp (a, σ) (a', σ')):
    step_cmd (Assign v a, σ) (Assign v a', σ')

| SO_Assign_Num σ v n:
    step_cmd (Assign v (Num n), σ) (Skip, update σ v n)

| SO_Cond σ σ' b b' c1 c2
          (SB: step_bexp (b, σ) (b', σ')):
    step_cmd (Cond b c1 c2, σ) (Cond b' c1 c2, σ')

| SO_Cond_TF σ c1 c2 b:
    step_cmd (Cond (Bool b) c1 c2, σ) ((if b then c1 else c2), σ)

| SO_While σ b c:
    step_cmd (While b c, σ) (Cond b (Seq c (While b c)) Skip, σ).

Notation "x ᵃ->₁ x'" := (step_aexp x x') (at level 70, x' at next level, no associativity).
Notation "x ᵇ->₁ x'" := (step_bexp 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 (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 70, x' at next level, no associativity).
Notation "x ᵇ->{ n  } x'" := (rtclosure step_bexp n x x') (at level 70, x' at next level, no associativity).
Notation "x ᶜ->{ n  } x'" := (rtclosure step_cmd n x x') (at level 70, x' at next level, no associativity).



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

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

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

Definition Gamma (eb: store -> bool) (ec: store -> option store) f σ :=
  if eb σ then (f ○ ec) σ else Some σ.

(* Γ is monotonic. *)
Lemma Gamma_mono: ∀ eb ec, monotonic (Gamma eb ec).
Proof.
  intros eb ec f g SS σ σ'. unfold Gamma,"○". destruct (eb σ).
    destruct (ec σ). apply SS. discriminate.
    trivial.
Qed.

Definition Γ (eb : store -> bool) (ec : store -> option store): store ⇀ store.
  apply (exist ωchain (Gamma eb ec)).
  intro n. induction n.
    discriminate.
    apply (Gamma_mono eb ec). apply IHn.
Defined.

Fixpoint exec_cmd c : store -> option store :=
  match c with
  | Skip => Some
  | Seq c1 c2 => (exec_cmd c2) ○ (exec_cmd c1)
  | Assign v a => (fun σ => Some (update σ v (eval_aexp a σ)))
  | Cond b c1 c2 => (fun σ => exec_cmd (if eval_bexp b σ then c1 else c2) σ)
  | 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 prove that Γ is indeed Scott-continuous: *)

Lemma Γ_scont: ∀ eb ec, scont (Γ eb ec).
Proof.
  intros eb ec σ H. simpl. unfold Gamma,"○".
  assert (H': ∀ n : nat, (!(Γ eb ec) ^ S n) ⊥ σ = None). intro n. apply H.
  simpl in H'. unfold Gamma at 1 in H'. unfold "○" in H'.
  destruct (eb σ).
    destruct (ec σ) as [σ2|].
      apply cp_fix_union, H'.
      reflexivity.
    apply (H' 0).
Qed.

Definition Γ_is_fixedpoint eb ec := is_fixedpoint (Γ eb ec) (Gamma_mono eb ec) (Γ_scont eb ec).


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

   All the proofs are pretty much the same, so I condense them into a macro below.
   (An even better way is to use "evaluation contexts", but we haven't covered that
   yet in class.)
 *)

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' σ σ', rtclosure R2 i (x,σ) (x',σ') -> rtclosure R1 i (op x, σ) (op x', σ').

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 really 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 σ n, (a,σ) ⇓ᵃ n -> ∃ i, (a,σ) ᵃ->{i} (Num n, σ).
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 *)
  edestruct IHconv_aexp1 as [i IH1]. eassumption. reflexivity.
  edestruct IHconv_aexp2 as [j IH2]. eassumption. reflexivity.
  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 σ p, (b,σ) ⇓ᵇ p -> ∃ i, (b,σ) ᵇ->{i} (Bool p, σ).
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 *)
  edestruct IHconv_bexp1 as [i IH1]. eassumption. reflexivity.
  edestruct IHconv_bexp2 as [j IH2]. eassumption. reflexivity.
  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 σ σ', (c,σ) ⇓ᶜ σ' -> ∃ i, (c,σ) ᶜ->{i} (Skip, σ').
Proof.
  intros. dependent induction H; subst.

  (* Skip *)
  exists 0. apply RTC_Refl.

  (* Seq *)
  edestruct IHconv_cmd1 as [i IH1]. eassumption. reflexivity.
  edestruct IHconv_cmd2 as [j IH2]. eassumption. reflexivity.
  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].
  edestruct IHconv_cmd as [j IH]. eassumption. reflexivity.
  exists (i+(S j)). eapply rtc_split.
    apply nstep_cond. exact SB.
    eapply RTC_Step. apply SO_Cond_TF. exact IH.

  (* While *)
  edestruct IHconv_cmd as [i IH]. eassumption. reflexivity.
  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' σ σ', (a,σ) ᵃ->₁(a',σ') -> σ = σ'.
Proof.
  intros. dependent induction H.
    reflexivity.
    eapply IHstep_aexp. eassumption. reflexivity. reflexivity.
    eapply IHstep_aexp. eassumption. reflexivity. reflexivity.
    reflexivity.
Qed.

Lemma bexp_step_pure:
  ∀ b b' σ σ', (b,σ) ᵇ->₁(b',σ') -> σ = σ'.
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. eassumption. reflexivity. reflexivity.
    reflexivity.
Qed.

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

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

Lemma bexp_step_pres:
  ∀ b b' σ σ', (b,σ) ᵇ->₁(b',σ') -> B〚b〛σ = B〚b'〛σ'.
Proof.
  intros. replace σ' with σ in *. clear σ'. 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 vareq b1 b1' σ); reflexivity.
    destruct (f p1); reflexivity.
  revert H. apply bexp_step_pure.
Qed.

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

  (* Seq c1 c2 --> Seq c1' cs *)
  rename c0 into c2. specialize (IHstep_cmd σ2 σ c1' c1 vareq 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') (σ':=σ2) by exact SA.
  replace σ2 with σ.
    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') (σ':=σ2) by exact SB.
  replace σ2 with σ.
    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 *)
  rewrite <- Γ_is_fixedpoint.
  simpl. unfold Gamma. destruct (B〚b〛σ2); reflexivity.
Qed.

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

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

Theorem cmd_SO_imp_DS:
  ∀ c σ σ' i, (c,σ) ᶜ->{i} (Skip, σ') -> C〚c〛σ = Some σ'.
Proof.
  intros. change (Some σ') with (C〚Skip〛σ'). revert c σ H. induction i; intros.
    inversion H; subst. reflexivity.
    inversion H; subst. destruct x2 as (c2,σ2). transitivity (C〚c2〛σ2).
      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 σ, (a,σ) ⇓ᵃ A〚a〛σ.
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 σ, (b,σ) ⇓ᵇ B〚b〛σ.
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 σ σ', C〚c〛σ = Some σ' -> (c,σ) ⇓ᶜ σ'.
Proof.
  induction c; intros; simpl in H.

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

  (* Seq *)
  unfold pcompose in H.
  specialize (IHc1 σ). destruct (exec_cmd c1 σ); [|discriminate].
  eapply LO_Seq.
    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 σ).
    apply bexp_DS_imp_LO.
    destruct (eval_bexp b σ).
      apply IHc1. assumption.
      apply IHc2. assumption.

  (* While *)
  revert σ σ' H. apply fixpoint_induction; intros.
  simpl in H. unfold Gamma 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 "○" in H. specialize (IHc x). destruct (exec_cmd c x); [|discriminate]. eapply LO_Seq.
        apply IHc. reflexivity.
        apply IH. assumption.
      injection H; intro; subst. apply LO_Skip.
Qed.

End Simpl.