Require Import RelationClasses.
Require Import ExtLib.Structures.Monad.
Require Import ExtLib.Structures.Reducible.

Set Implicit Arguments.
Set Strict Implicit.

(** First-class maps **)
Section Maps.
  Variables K V : Type.
  Variable map : Type.

  (** General Maps **)
  Class Map : Type :=
  { empty    : map
  ; add      : K -> V -> map -> map
  ; remove   : K -> map -> map
  ; lookup   : K -> map -> option V
  ; union    : map -> map -> map
  }.

  Variable R : K -> K -> Prop.

  Class MapOk (M : Map) : Type :=
  { mapsto : K -> V -> map -> Prop
  ; mapsto_empty : forall k v, ~mapsto k v empty
  ; mapsto_lookup : forall k v m, lookup k m = Some v <-> mapsto k v m
  ; mapsto_add_eq : forall m k v, mapsto k v (add k v m)
  ; mapsto_add_neq : forall m k v k',
                       ~R k k' ->
                       forall v', (mapsto k' v' m <-> mapsto k' v' (add k v m))
  }.

  Variable M : Map.

  Definition contains (k : K) (m : map) : bool :=
    match lookup k m with
      | None => false
      | Some _ => true
    end.

  Definition singleton (k : K) (v : V) : map :=
    add k v empty.

  (* Finite Maps *)
  Context {F : Foldable map (K * V)}.

  Definition combine (f : K -> V -> V -> V) (m1 m2 : map) : map :=
    fold (fun k_v acc =>
      let '(k,v) := k_v in
      match lookup k acc with
        | None => add k v acc
        | Some v' => add k (f k v v') acc
      end) m2 m1.

  Definition filter (f : K -> V -> bool) (m : map) : map :=
    fold (fun k_v acc =>
      let '(k,v) := k_v in
      if f k v
        then add k v acc
        else acc) empty m.

  Definition submap_with (le : V -> V -> bool) (m1 m2 : map) : bool :=
    fold (fun k_v (acc : bool) =>
      if acc then
        let '(k,v) := k_v in
        match lookup k m2 with
          | None => false
          | Some v' => le v v'
        end
      else false) true m1.

(*
  Definition keys (s : Type) (_ : DMonad s K) : map T -> s :=
    fold (fun k_v (acc : s) =>
      djoin (dreturn (fst k_v)) acc) dzero.

  Definition values (s : Type) (_ : DMonad s T) : map T -> s :=
    fold (fun k_v (acc : s) =>
      djoin (dreturn (snd k_v)) acc) dzero.
*)

End Maps.

Arguments empty {_} {_} {_} {_} .
Arguments add {K V} {map} {Map} _ _ _.
Arguments remove {K V} {map} {Map} _ _.
Arguments lookup {K V} {map} {Map} _ _.
Arguments contains {K V} {map} {M} _ _.
Arguments singleton {K V} {map} {M} _ _.
Arguments combine {K V} {map} {M} _ _ _ _.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Import XRbase.
Require Import XRfunctions.
Require Import XPartSum.
Local Open Scope XR_scope.

Definition C (n p:nat) : R :=
  INR (fact n) / (INR (fact p) * INR (fact (n - p))).

Lemma pascal_step1 : forall n i:nat, (i <= n)%nat -> C n i = C n (n - i).
Proof.
  intros; unfold C; replace (n - (n - i))%nat with i.
  rewrite Rmult_comm.
  reflexivity.
  apply plus_minus; rewrite plus_comm; apply le_plus_minus; assumption.
Qed.

Lemma pascal_step2 :
  forall n i:nat,
    (i <= n)%nat -> C (S n) i = INR (S n) / INR (S n - i) * C n i.
Proof.
  intros; unfold C; replace (S n - i)%nat with (S (n - i)).
  cut (forall n:nat, fact (S n) = (S n * fact n)%nat).
  intro; repeat rewrite H0.
  unfold Rdiv; repeat rewrite mult_INR; repeat rewrite Rinv_mult_distr.
  repeat rewrite Rmult_assoc.
  apply Rmult_eq_compat_l.
  symmetry.
  rewrite Rmult_comm.
repeat rewrite Rmult_assoc.
  apply Rmult_eq_compat_l.
apply Rmult_eq_compat_l.
rewrite Rmult_comm.
reflexivity.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  apply not_O_INR; discriminate.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  apply prod_neq_R0.
  apply not_O_INR; discriminate.
  apply INR_fact_neq_0.
  intro; reflexivity.
  apply minus_Sn_m; assumption.
Qed.

Lemma pascal_step3 :
  forall n i:nat, (i < n)%nat -> C n (S i) = INR (n - i) / INR (S i) * C n i.
Proof.
  intros; unfold C.
  cut (forall n:nat, fact (S n) = (S n * fact n)%nat).
  intro.
  cut ((n - i)%nat = S (n - S i)).
  intro.
  pattern (n - i)%nat at 2; rewrite H1.
  repeat rewrite H0; unfold Rdiv; repeat rewrite mult_INR;
    repeat rewrite Rinv_mult_distr.
  rewrite <- H1; rewrite (Rmult_comm (/ INR (n - i)));
    repeat rewrite Rmult_assoc; rewrite (Rmult_comm (INR (n - i)));
      repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
repeat rewrite Rmult_assoc.
symmetry.
rewrite Rmult_comm.
repeat rewrite Rmult_assoc.
apply Rmult_eq_compat_l.
symmetry.
rewrite Rmult_comm.
repeat rewrite Rmult_assoc.
apply Rmult_eq_compat_l.
rewrite Rmult_1_l.
reflexivity.
  apply not_O_INR; apply minus_neq_O; assumption.
  apply not_O_INR; discriminate.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  apply prod_neq_R0; [ apply not_O_INR; discriminate | apply INR_fact_neq_0 ].
  apply not_O_INR; discriminate.
  apply INR_fact_neq_0.
  apply prod_neq_R0; [ apply not_O_INR; discriminate | apply INR_fact_neq_0 ].
  apply INR_fact_neq_0.
  rewrite minus_Sn_m.
  simpl; reflexivity.
  apply lt_le_S; assumption.
  intro; reflexivity.
Qed.

  (**********)
Lemma pascal :
  forall n i:nat, (i < n)%nat -> C n i + C n (S i) = C (S n) (S i).
Proof.
  intros.
  rewrite pascal_step3; [ idtac | assumption ].
  replace (C n i + INR (n - i) / INR (S i) * C n i) with
    (C n i * (R1 + INR (n - i) / INR (S i))).
2:{
rewrite Rmult_plus_distr_l.
rewrite Rmult_1_r.
repeat rewrite Rplus_assoc.
apply Rplus_eq_compat_l.
rewrite Rmult_comm.
reflexivity.
}
  replace (R1 + INR (n - i) / INR (S i)) with (INR (S n) / INR (S i)).
  rewrite pascal_step1.
  rewrite Rmult_comm; replace (S i) with (S n - (n - i))%nat.
  rewrite <- pascal_step2.
  apply pascal_step1.
  apply le_trans with n.
  apply le_minusni_n.
  apply lt_le_weak; assumption.
  apply le_n_Sn.
  apply le_minusni_n.
  apply lt_le_weak; assumption.
  rewrite <- minus_Sn_m.
  cut ((n - (n - i))%nat = i).
  intro; rewrite H0; reflexivity.
  symmetry ; apply plus_minus.
  rewrite plus_comm; rewrite le_plus_minus_r.
  reflexivity.
  apply lt_le_weak; assumption.
  apply le_minusni_n; apply lt_le_weak; assumption.
  apply lt_le_weak; assumption.
  unfold Rdiv.
  repeat rewrite S_INR.
  rewrite minus_INR.
  cut (INR i + R1 <> R0).
  intro.
  apply Rmult_eq_reg_l with (INR i + R1); [ idtac | assumption ].
  rewrite Rmult_plus_distr_l.
  rewrite Rmult_1_r.
  do 2 rewrite (Rmult_comm (INR i + R1)).
  repeat rewrite Rmult_assoc.
  rewrite <- Rinv_l_sym; [ idtac | assumption ].
  rewrite Rmult_1_r.
rewrite Rmult_1_r.
repeat rewrite Rplus_assoc.
rewrite Rplus_comm.
symmetry.
rewrite Rplus_comm.
repeat rewrite Rplus_assoc.
apply Rplus_eq_compat_l.
unfold Rminus.
repeat rewrite Rplus_assoc.
rewrite Rplus_opp_l.
rewrite Rplus_0_r.
reflexivity.
  rewrite <- S_INR.
  apply not_O_INR; discriminate.
  apply lt_le_weak; assumption.
Qed.

  (*********************)
  (*********************)
Lemma binomial :
  forall (x y:R) (n:nat),
    (x + y) ^ n = sum_f_R0 (fun i:nat => C n i * x ^ i * y ^ (n - i)) n.
Proof.
  intros; induction  n as [| n Hrecn].
  unfold C; simpl; unfold Rdiv;
    repeat rewrite Rmult_1_r; rewrite Rinv_1.
rewrite Rmult_1_r.
reflexivity.
  pattern (S n) at 1; replace (S n) with (n + 1)%nat; [ idtac | ring ].
  rewrite pow_add; rewrite Hrecn.
  replace ((x + y) ^ 1) with (x + y).
2:{
simpl.
rewrite Rmult_1_r.
reflexivity.
}
  rewrite tech5.
  cut (forall p:nat, C p p = R1).
  cut (forall p:nat, C p 0 = R1).
  intros; rewrite H0; rewrite <- minus_n_n; rewrite Rmult_1_l.
  replace (y ^ 0) with R1; [ rewrite Rmult_1_r | simpl; reflexivity ].
  induction  n as [| n Hrecn0].
  simpl; do 2 rewrite H.
repeat rewrite Rmult_1_r.
repeat rewrite Rmult_1_l.
rewrite Rplus_comm.
reflexivity.
  (* N >= 1 *)
  set (N := S n).
  rewrite Rmult_plus_distr_l.
  replace (sum_f_R0 (fun i:nat => C N i * x ^ i * y ^ (N - i)) N * x) with
    (sum_f_R0 (fun i:nat => C N i * x ^ S i * y ^ (N - i)) N).
  replace (sum_f_R0 (fun i:nat => C N i * x ^ i * y ^ (N - i)) N * y) with
    (sum_f_R0 (fun i:nat => C N i * x ^ i * y ^ (S N - i)) N).
  rewrite (decomp_sum (fun i:nat => C (S N) i * x ^ i * y ^ (S N - i)) N).
  rewrite H; replace (x ^ 0) with R1; [ idtac | reflexivity ].
  do 2 rewrite Rmult_1_l.
  replace (S N - 0)%nat with (S N); [ idtac | reflexivity ].
  set (An := fun i:nat => C N i * x ^ S i * y ^ (N - i)).
  set (Bn := fun i:nat => C N (S i) * x ^ S i * y ^ (N - i)).
  replace (pred N) with n.
  replace (sum_f_R0 (fun i:nat => C (S N) (S i) * x ^ S i * y ^ (S N - S i)) n)
    with (sum_f_R0 (fun i:nat => An i + Bn i) n).
  rewrite plus_sum.
  replace (x ^ S N) with (An (S n)).
  rewrite (Rplus_comm (sum_f_R0 An n)).
  repeat rewrite Rplus_assoc.
  rewrite <- tech5.
  fold N.
  set (Cn := fun i:nat => C N i * x ^ i * y ^ (S N - i)).
  cut (forall i:nat, (i < N)%nat -> Cn (S i) = Bn i).
  intro; replace (sum_f_R0 Bn n) with (sum_f_R0 (fun i:nat => Cn (S i)) n).
  replace (y ^ S N) with (Cn 0%nat).
  rewrite <- Rplus_assoc; rewrite (decomp_sum Cn N).
  replace (pred N) with n.
repeat rewrite Rplus_assoc.
rewrite Rplus_comm.
repeat rewrite Rplus_assoc.
apply Rplus_eq_compat_l.
reflexivity.
  unfold N; simpl; reflexivity.
  unfold N; apply lt_O_Sn.
  unfold Cn; rewrite H; simpl.
repeat rewrite Rmult_1_l.
reflexivity.
  apply sum_eq.
  intros; apply H1.
  unfold N; apply le_lt_trans with n; [ assumption | apply lt_n_Sn ].
  reflexivity.
  unfold An; fold N; rewrite <- minus_n_n; rewrite H0;
    simpl.
repeat rewrite Rmult_1_l.
repeat rewrite Rmult_1_r.
reflexivity.
  apply sum_eq.
  intros; unfold An, Bn.
  change (S N - S i)%nat with (N - i)%nat.
  rewrite <- pascal.
rewrite Rmult_plus_distr_r.
rewrite Rmult_plus_distr_r.
reflexivity.
      apply le_lt_trans with n; [ assumption | unfold N; apply lt_n_Sn ].
  unfold N; reflexivity.
  unfold N; apply lt_O_Sn.
  rewrite <- (Rmult_comm y); rewrite scal_sum; apply sum_eq.
  intros; replace (S N - i)%nat with (S (N - i)).
  replace (S (N - i)) with (N - i + 1)%nat; [ idtac | ring ].
  rewrite pow_add; replace (y ^ 1) with y.
2:{
simpl.
rewrite Rmult_1_r.
reflexivity.
}
repeat rewrite Rmult_assoc.
reflexivity.
  apply minus_Sn_m; assumption.
  rewrite <- (Rmult_comm x); rewrite scal_sum; apply sum_eq.
  intros; replace (S i) with (i + 1)%nat; [ idtac | ring ]; rewrite pow_add;
    replace (x ^ 1) with x.
2:{
simpl.
rewrite Rmult_1_r.
reflexivity.
}
repeat rewrite Rmult_assoc.
apply Rmult_eq_compat_l.
apply Rmult_eq_compat_l.
rewrite Rmult_comm.
reflexivity.
  intro; unfold C.
  replace (INR (fact 0)) with R1; [ idtac | reflexivity ].
  replace (p - 0)%nat with p; [ idtac | apply minus_n_O ].
  rewrite Rmult_1_l; unfold Rdiv; rewrite <- Rinv_r_sym;
    [ reflexivity | apply INR_fact_neq_0 ].
  intro; unfold C.
  replace (p - p)%nat with 0%nat; [ idtac | apply minus_n_n ].
  replace (INR (fact 0)) with R1; [ idtac | reflexivity ].
  rewrite Rmult_1_r; unfold Rdiv; rewrite <- Rinv_r_sym;
    [ reflexivity | apply INR_fact_neq_0 ].
Qed.


(** * Equiv: Program Equivalence *)

(* $Date: 2011-04-05 21:37:47 -0400 (Tue, 05 Apr 2011) $ *)

Require Export Imp.

(** *** Some general advice for homework assignments

    - We've tried to make sure that most of the Coq proofs we ask you
      to do are similar to proofs that we've provided.  Before
      starting to work on the homework problems, take the time to work
      through our proofs (both informally, on paper, and in Coq) and
      make sure you understand them in detail.  This will save you a
      lot of time.

    - The Coq proofs we're doing now are sufficiently complicated that
      it is more or less impossible to complete them simply by
      "following your nose" or random hacking.  You need to start with
      an idea about why the property is true and how the proof is
      going to go.  The best way to do this is to write out at least a
      sketch of an informal proof on paper -- one that intuitively
      convinces you of the truth of the theorem -- before starting to
      work on the formal one.

    - Use automation to save work!  Some of the proofs in this
      chapter's exercises are pretty long if you try to write out all
      the cases explicitly. *)

(* ####################################################### *)
(** * Behavioral Equivalence *)

(** In the last chapter, we investigated the correctness of a very
    simple program transformation: the [optimize_0plus] function.  The
    programming language we were considering was the first version of
    the language of arithmetic expressions -- with no variables -- so
    it was very easy to define what it _means_ for a program
    transformation to be correct: it should always yield a program
    that evaluates to the same number as the original.

    To talk about the correctness of program transformations in the
    full Imp language, we need to think about the role of variables
    and the state. *)

(* ####################################################### *)
(** ** Definitions *)

(** For [aexp]s and [bexp]s, the definition we want is clear.  We say
    that two [aexp]s or [bexp]s are _behaviorally equivalent_ if they
    evaluate to the same result _in every state_. *)

Definition aequiv (a1 a2 : aexp) : Prop :=
  forall (st:state),
    aeval st a1 = aeval st a2.

Definition bequiv (b1 b2 : bexp) : Prop :=
  forall (st:state),
    beval st b1 = beval st b2.

(** For commands, the situation is a little more subtle.  We can't
    simply say "two commands are behaviorally equivalent if they
    evaluate to the same ending state whenever they are run in the
    same initial state," because some commands (in some starting
    states) don't terminate in any final state at all!  What we need
    instead is this: two commands are behaviorally equivalent if, for
    any given starting state, they either both diverge or both
    terminate in the same final state.  A compact way to express this
    is "if the first one terminates in a particular state then so does
    the second, and vice versa." *)

Definition cequiv (c1 c2 : com) : Prop :=
  forall (st st':state),
    (c1 / st || st') <-> (c2 / st || st').

(** **** Exercise: 2 stars, optional (pairs_equiv) *)
(** Which of the following pairs of programs are equivalent? Write
    "yes" or "no" for each one.

(a)
[[
    WHILE (BLe (ANum 1) (AId X)) DO
      X ::= APlus (AId X) (ANum 1)
    END
]]
    and
[[
    WHILE (BLe (ANum 2) (AId X)) DO
      X ::= APlus (AId X) (ANum 1)
    END
]]
(* FILL IN HERE *)

(b)
[[
    WHILE BTrue DO
      WHILE BFalse DO X ::= APlus (AId X) (ANum 1) END
    END
]]
and
[[
    WHILE BFalse DO
      WHILE BTrue DO X ::= APlus (AId X) (ANum 1) END
    END
]]

(* FILL IN HERE *)

[] *)

(* ####################################################### *)
(** ** Examples *)

Theorem aequiv_example:
  aequiv (AMinus (AId X) (AId X)) (ANum 0).
Proof.
  intros st. simpl. apply minus_diag.
Qed.

Theorem bequiv_example:
  bequiv (BEq (AMinus (AId X) (AId X)) (ANum 0)) BTrue.
Proof.
  intros st. unfold beval.
  rewrite aequiv_example. reflexivity.
Qed.

(** For examples of command equivalence, let's start by looking at
    trivial transformations involving [SKIP]: *)

Theorem skip_left: forall c,
  cequiv
     (SKIP; c)
     c.
Proof.
  intros c st st'.
  split; intros H.
  Case "->".
    inversion H. subst.
    inversion H2. subst.
    assumption.
  Case "<-".
    apply E_Seq with st.
    apply E_Skip.
    assumption.
Qed.

(** **** Exercise: 2 stars (skip_right) *)
Theorem skip_right: forall c,
  cequiv
    (c; SKIP)
    c.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** We can also explore transformations that simplify [IFB]
    commands: *)

Theorem IFB_true_simple: forall c1 c2,
  cequiv
    (IFB BTrue THEN c1 ELSE c2 FI)
    c1.
Proof.
  intros c1 c2.
  split; intros H.
  Case "->".
    inversion H; subst. assumption. inversion H5.
  Case "<-".
    apply E_IfTrue. reflexivity. assumption.  Qed.

(** Of course, few programmers would be tempted to write a conditional
    whose guard is literally [BTrue].  A more interesting case is when
    the guard is _equivalent_ to true...

   _Theorem_: If [b] is equivalent to [BTrue], then [IFB b THEN c1
   ELSE c2 FI] is equivalent to [c1].

   _Proof_:

     - ([->]) We must show, for all [st] and [st'], that if [IFB b
       THEN c1 ELSE c2 FI / st || st'] then [c1 / st || st'].

       Proceed by cases on the rules that could possibly have been
       used to show [IFB b THEN c1 ELSE c2 FI / st || st'], namely
       [E_IfTrue] and [E_IfFalse].

       - Suppose the final rule rule in the derivation of [IFB b THEN
         c1 ELSE c2 FI / st || st'] was [E_IfTrue].  We then have, by
         the premises of [E_IfTrue], that [c1 / st || st'].  This is
         exactly what we set out to prove.

       - On the other hand, suppose the final rule in the derivation
         of [IFB b THEN c1 ELSE c2 FI / st || st'] was [E_IfFalse].
         We then know that [beval st b = false] and [c2 / st || st'].

         Recall that [b] is equivalent to [BTrue], i.e. forall [st],
         [beval st b = beval st BTrue].  In particular, this means
         that [beval st b = true], since [beval st BTrue = true].  But
         this is a contradiction, since [E_IfFalse] requires that
         [beval st b = false].  Thus, the final rule could not have
         been [E_IfFalse].

     - ([<-]) We must show, for all [st] and [st'], that if [c1 / st
       || st'] then [IFB b THEN c1 ELSE c2 FI / st || st'].

       Since [b] is equivalent to [BTrue], we know that [beval st b] =
       [beval st BTrue] = [true].  Together with the assumption that
       [c1 / st || st'], we can apply [E_IfTrue] to derive [IFB b THEN
       c1 ELSE c2 FI / st || st'].  []

   Here is the formal version of this proof: *)

Theorem IFB_true: forall b c1 c2,
     bequiv b BTrue  ->
     cequiv
       (IFB b THEN c1 ELSE c2 FI)
       c1.
Proof.
  intros b c1 c2 Hb.
  split; intros H.
  Case "->".
    inversion H; subst.
    SCase "b evaluates to true".
      assumption.
    SCase "b evaluates to false (contradiction)".
      rewrite Hb in H5.
      inversion H5.
  Case "<-".
    apply E_IfTrue; try assumption.
    rewrite Hb. reflexivity.  Qed.

(** **** Exercise: 2 stars, recommended (IFB_false) *)
Theorem IFB_false: forall b c1 c2,
  bequiv b BFalse  ->
  cequiv
    (IFB b THEN c1 ELSE c2 FI)
    c2.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars (swap_if_branches) *)
Theorem swap_if_branches: forall b e1 e2,
  cequiv
    (IFB b THEN e1 ELSE e2 FI)
    (IFB BNot b THEN e2 ELSE e1 FI).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** For while loops, there is a similar pair of theorems: a loop whose
    guard is equivalent to [BFalse] is equivalent to [SKIP], while a
    loop whose guard is equivalent to [BTrue] is equivalent to [WHILE
    BTrue DO SKIP END] (or any other non-terminating program).  The
    first of these facts is easy. *)

Theorem WHILE_false : forall b c,
     bequiv b BFalse ->
     cequiv
       (WHILE b DO c END)
       SKIP.
Proof.
  intros b c Hb. split; intros H.
  Case "->".
    inversion H; subst.
    SCase "E_WhileEnd".
      apply E_Skip.
    SCase "E_WhileLoop".
      rewrite Hb in H2. inversion H2.
  Case "<-".
    inversion H; subst.
    apply E_WhileEnd.
    rewrite Hb.
    reflexivity.  Qed.

(** **** Exercise: 2 stars (WHILE_false_informal) *)
(** Write an informal proof of WHILE_false.

(* FILL IN HERE *)
[]
*)

(** To prove the second fact, we need an auxiliary lemma stating that
    while loops whose guards are equivalent to [BTrue] never
    terminate:

    _Lemma_: If [b] is equivalent to [BTrue], then it cannot be the
    case that [(WHILE b DO c END) / st || st'].

    _Proof_: Suppose that [(WHILE b DO c END) / st || st'].  We show,
    by induction on a derivation of [(WHILE b DO c END) / st || st'],
    that this assumption leads to a contradiction.

      - Suppose [(WHILE b DO c END) / st || st'] is proved using rule
        [E_WhileEnd].  Then by assumption [beval st b = false].  But
        this contradicts the assumption that [b] is equivalent to
        [BTrue].

      - Suppose [(WHILE b DO c END) / st || st'] is proved using rule
        [E_WhileLoop].  Then we are given the induction hypothesis
        that [(WHILE b DO c END) / st || st'] is contradictory, which
        is exactly what we are trying to prove!

      - Since these are the only rules that could have been used to
        prove [(WHILE b DO c END) / st || st'], the other cases of
        the induction are immediately contradictory. [] *)

Lemma WHILE_true_nonterm : forall b c st st',
     bequiv b BTrue ->
     ~( (WHILE b DO c END) / st || st' ).
Proof.
  intros b c st st' Hb.
  intros H.
  remember (WHILE b DO c END) as cw.
  ceval_cases (induction H) Case;
    (* Most rules don't apply, and we can rule them out
       by inversion *)
    inversion Heqcw; subst; clear Heqcw.
  (* The two interesting cases are the ones for while loops: *)
  Case "E_WhileEnd". (* contradictory -- b is always true! *)
    rewrite Hb in H. inversion H.
  Case "E_WhileLoop". (* immediate from the IH *)
    apply IHceval2. reflexivity.  Qed.

(** **** Exercise: 2 stars, optional (WHILE_true_nonterm_informal) *)
(** Explain what the lemma [WHILE_true_nonterm] means in English.

(* FILL IN HERE *)
*)
(** [] *)

(** **** Exercise: 2 stars, recommended (WHILE_true) *)
(** You'll want to use [WHILE_true_nonterm] here. *)

Theorem WHILE_true: forall b c,
     bequiv b BTrue  ->
     cequiv
       (WHILE b DO c END)
       (WHILE BTrue DO SKIP END).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

Theorem loop_unrolling: forall b c,
  cequiv
    (WHILE b DO c END)
    (IFB b THEN (c; WHILE b DO c END) ELSE SKIP FI).
Proof.
  (* WORKED IN CLASS *)
  intros b c st st'.
  split; intros Hce.
  Case "->".
    inversion Hce; subst.
    SCase "loop doesn't run".
      apply E_IfFalse. assumption. apply E_Skip.
    SCase "loop runs".
      apply E_IfTrue. assumption.
      apply E_Seq with (st' := st'0). assumption. assumption.
  Case "<-".
    inversion Hce; subst.
    SCase "loop runs".
      inversion H5; subst.
      apply E_WhileLoop with (st' := st'0).
      assumption. assumption. assumption.
    SCase "loop doesn't run".
      inversion H5; subst. apply E_WhileEnd. assumption.  Qed.

(** **** Exercise: 2 stars, optional (seq_assoc) *)
Theorem seq_assoc : forall c1 c2 c3,
  cequiv ((c1;c2);c3) (c1;(c2;c3)).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Finally, let's look at simple equivalences involving assignments.
    This turns out to be a little tricky.
    To start with, we might expect to be able to show that certain
    kinds of "useless" assignments can be removed. Most trivially: *)

Theorem identity_assignment_first_try : forall (X:id),
  cequiv
    (X ::= AId X)
    SKIP.
Proof.
   intros. split; intro H.
     Case "->".
       inversion H; subst.  simpl.
       replace (update st X (st X)) with st.
       constructor.
       (* But here we're stuck. The goal looks reasonable, but in fact
          it is not provable!  If we look back at the set of lemmas we
          proved about [update] in the last chapter, we can see that
          lemma [update_same] almost does the job, but not quite: it
          says that the original and updated states agree at all
          values, but this is not the same thing as saying that they
          are [eq] in Coq's sense! *)
Admitted.

(** What is going on here?  Recall that our states are just functions
    from identifiers to values.  For Coq, functions are only equal
    when their definitions are syntactically the same, modulo
    simplification.  (This is the only way we can legally apply the
    [eq] constructor!) In practice, for functions built up by repeated
    uses of the [update] operation, this means that two functions can
    be proven equal only if they were constructed using the _same_
    [update] operations, applied in the same order.  In the theorem
    above, the sequence of updates on the first parameter [cequiv] is
    one longer than for the second parameter, so it is no wonder that
    the equality doesn't hold.

    But the problem is quite general. If we try to prove other
    "trivial" facts, such as
[[
    cequiv (X ::= APlus (AId X ANum 1) ;
            X ::= APlus (AId X ANum 1))
           (X ::= APlus (AId X ANum 2))
]]
    or
[[
    cequiv (X ::= ANum 1; Y ::= ANum 2)
           (y ::= ANum 2; X ::= ANum 1)

]]
    we'll get stuck in the same way: we'll have two functions that
    behave the same way on all inputs, but cannot be proven to be [eq]
    to each other.

    The reasoning principle we would like to use in these situations
    is called _functional extensionality_:
[[[
                        forall x, f x = g x
                        -------------------
                               f = g
]]]
    Although this principle is not derivable in Coq's built-in logic,
    it is safe to add it as an additional _axiom_.  *)

Axiom functional_extensionality : forall {X Y: Type} {f g : X -> Y},
    (forall (x: X), f x = g x) ->  f = g.

(** It can be shown that adding this axiom doesn't introduce any
    inconsistencies into Coq.  (In this way, it is similar to adding
    one of the classical logic axioms, such as [excluded_middle].)

    With the benefit of this axiom we can prove our theorem: *)

Theorem identity_assignment : forall (X:id),
  cequiv
    (X ::= AId X)
    SKIP.
Proof.
   intros. split; intro H.
     Case "->".
       inversion H; subst. simpl.
       replace (update st X (st X)) with st.
       constructor.
       apply functional_extensionality. intro.
       rewrite update_same; reflexivity.
     Case "<-".
       inversion H; subst.
       assert (st' = (update st' X (st' X))).
          apply functional_extensionality. intro.
          rewrite update_same; reflexivity.
       rewrite H0 at 2.
       constructor. reflexivity.
Qed.

(** **** Exercise: 2 stars, recommended (assign_aequiv) *)
Theorem assign_aequiv : forall X e,
  aequiv (AId X) e ->
  cequiv SKIP (X ::= e).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ####################################################### *)
(** * Properties of Behavioral Equivalence *)

(** We now turn to developing some of the properties of the program
    equivalences we have defined. *)

(* ####################################################### *)
(** ** Behavioral Equivalence is an Equivalence *)

(** First, we verify that the equivalences on [aexps], [bexps], and
    [com]s really are _equivalences_ -- i.e., that they are reflexive,
    symmetric, and transitive: *)

Lemma refl_aequiv : forall (a : aexp), aequiv a a.
Proof.
  intros a st. reflexivity.  Qed.

Lemma sym_aequiv : forall (a1 a2 : aexp),
  aequiv a1 a2 -> aequiv a2 a1.
Proof.
  intros a1 a2 H. intros st. symmetry. apply H.  Qed.

Lemma trans_aequiv : forall (a1 a2 a3 : aexp),
  aequiv a1 a2 -> aequiv a2 a3 -> aequiv a1 a3.
Proof.
  unfold aequiv. intros a1 a2 a3 H12 H23 st.
  rewrite (H12 st). rewrite (H23 st). reflexivity.  Qed.

Lemma refl_bequiv : forall (b : bexp), bequiv b b.
Proof.
  unfold bequiv. intros b st. reflexivity.  Qed.

Lemma sym_bequiv : forall (b1 b2 : bexp),
  bequiv b1 b2 -> bequiv b2 b1.
Proof.
  unfold bequiv. intros b1 b2 H. intros st. symmetry. apply H.  Qed.

Lemma trans_bequiv : forall (b1 b2 b3 : bexp),
  bequiv b1 b2 -> bequiv b2 b3 -> bequiv b1 b3.
Proof.
  unfold bequiv. intros b1 b2 b3 H12 H23 st.
  rewrite (H12 st). rewrite (H23 st). reflexivity.  Qed.

Lemma refl_cequiv : forall (c : com), cequiv c c.
Proof.
  unfold cequiv. intros c st st'. apply iff_refl.  Qed.

Lemma sym_cequiv : forall (c1 c2 : com),
  cequiv c1 c2 -> cequiv c2 c1.
Proof.
  unfold cequiv. intros c1 c2 H st st'.
  assert (c1 / st || st' <-> c2 / st || st') as H'.
    SCase "Proof of assertion". apply H.
  apply iff_sym. assumption.
Qed.

Lemma iff_trans : forall (P1 P2 P3 : Prop),
  (P1 <-> P2) -> (P2 <-> P3) -> (P1 <-> P3).
Proof.
  intros P1 P2 P3 H12 H23.
  inversion H12. inversion H23.
  split; intros A.
    apply H1. apply H. apply A.
    apply H0. apply H2. apply A.  Qed.

Lemma trans_cequiv : forall (c1 c2 c3 : com),
  cequiv c1 c2 -> cequiv c2 c3 -> cequiv c1 c3.
Proof.
  unfold cequiv. intros c1 c2 c3 H12 H23 st st'.
  apply iff_trans with (c2 / st || st'). apply H12. apply H23.  Qed.

(* ########################################################*)
(** ** Behavioral Equivalence is a Congruence *)

(** Less obviously, behavioral equivalence is also a _congruence_.
    That is, the equivalence of two subprograms implies the
    equivalence of the whole programs in which they are embedded:
[[[
              aequiv a1 a1'
      -----------------------------
      cequiv (i ::= a1) (i ::= a1')

              cequiv c1 c1'
              cequiv c2 c2'
         ------------------------
         cequiv (c1;c2) (c1';c2')
]]]
    ...and so on.  (Note that we are using the inference rule notation
    here not as part of a definition, but simply to write down some
    valid implications in a readable format. We prove these
    implications below.)

    We will see a concrete example of why these congruence properties
    are important in the following section (in the proof of
    [fold_constants_com_sound]), but the main idea is that they allow
    us to replace a small part of a large program with an equivalent
    small part and know that the whole large programs are equivalent
    _without_ doing an explicit proof about the non-varying parts --
    i.e., the "proof burden" of a small change to a large program is
    proportional to the size of the change, not the program. *)

Theorem CAss_congruence : forall i a1 a1',
  aequiv a1 a1' ->
  cequiv (CAss i a1) (CAss i a1').
Proof.
  intros i a1 a2 Heqv st st'.
  split; intros Hceval.
  Case "->".
    inversion Hceval. subst. apply E_Ass.
    rewrite Heqv. reflexivity.
  Case "<-".
    inversion Hceval. subst. apply E_Ass.
    rewrite Heqv. reflexivity.  Qed.

(** The congruence property for loops is a little more interesting,
    since it requires induction.

    _Theorem_: Equivalence is a congruence for [WHILE] -- that is, if
    [b1] is equivalent to [b1'] and [c1] is equivalent to [c1'], then
    [WHILE b1 DO c1 END] is equivalent to [WHILE b1' DO c1' END].

    _Proof_: Suppose [b1] is equivalent to [b1'] and [c1] is
    equivalent to [c1'].  We must show, for every [st] and [st'], that
    [WHILE b1 DO c1 END / st || st'] iff [WHILE b1' DO c1' END / st
    || st'].  We consider the two directions separately.

      - ([->]) We show that [WHILE b1 DO c1 END / st || st'] implies
        [WHILE b1' DO c1' END / st || st'], by induction on a
        derivation of [WHILE b1 DO c1 END / st || st'].  The only
        nontrivial cases are when the final rule in the derivation is
        [E_WhileEnd] or [E_WhileLoop].

          - [E_WhileEnd]: In this case, the form of the rule gives us
            [beval st b1 = false] and [st = st'].  But then, since
            [b1] and [b1'] are equivalent, we have [beval st b1' =
            false], and [E-WhileEnd] applies, giving us [WHILE b1' DO
            c1' END / st || st'], as required.

          - [E_WhileLoop]: The form of the rule now gives us [beval st
            b1 = true], with [c1 / st || st'0] and [WHILE b1 DO c1
            END / st'0 || st'] for some state [st'0], with the
            induction hypothesis [WHILE b1' DO c1' END / st'0 ||
            st'].

            Since [c1] and [c1'] are equivalent, we know that [c1' /
            st || st'0].  And since [b1] and [b1'] are equivalent, we
            have [beval st b1' = true].  Now [E-WhileLoop] applies,
            giving us [WHILE b1' DO c1' END / st || st'], as
            required.

      - ([<-]) Similar. [] *)

Theorem CWhile_congruence : forall b1 b1' c1 c1',
  bequiv b1 b1' -> cequiv c1 c1' ->
  cequiv (WHILE b1 DO c1 END) (WHILE b1' DO c1' END).
Proof.
  unfold bequiv,cequiv.
  intros b1 b1' c1 c1' Hb1e Hc1e st st'.
  split; intros Hce.
  Case "->".
    remember (WHILE b1 DO c1 END) as cwhile.
    induction Hce; inversion Heqcwhile; subst.
    SCase "E_WhileEnd".
      apply E_WhileEnd. rewrite <- Hb1e. apply H.
    SCase "E_WhileLoop".
      apply E_WhileLoop with (st' := st').
      SSCase "show loop runs". rewrite <- Hb1e. apply H.
      SSCase "body execution".
        apply (Hc1e st st').  apply Hce1.
      SSCase "subsequent loop execution".
        apply IHHce2. reflexivity.
  Case "<-".
    remember (WHILE b1' DO c1' END) as c'while.
    induction Hce; inversion Heqc'while; subst.
    SCase "E_WhileEnd".
      apply E_WhileEnd. rewrite -> Hb1e. apply H.
    SCase "E_WhileLoop".
      apply E_WhileLoop with (st' := st').
      SSCase "show loop runs". rewrite -> Hb1e. apply H.
      SSCase "body execution".
        apply (Hc1e st st').  apply Hce1.
      SSCase "subsequent loop execution".
        apply IHHce2. reflexivity.  Qed.

(** **** Exercise: 3 stars, optional (CSeq_congruence) *)
Theorem CSeq_congruence : forall c1 c1' c2 c2',
  cequiv c1 c1' -> cequiv c2 c2' ->
  cequiv (c1;c2) (c1';c2').
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars (CIf_congruence) *)
Theorem CIf_congruence : forall b b' c1 c1' c2 c2',
  bequiv b b' -> cequiv c1 c1' -> cequiv c2 c2' ->
  cequiv (IFB b THEN c1 ELSE c2 FI) (IFB b' THEN c1' ELSE c2' FI).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** For example, here are two equivalent programs and a proof of their
    equivalence... *)

Example congruence_example:
  cequiv
    (X ::= ANum 0;
     IFB (BEq (AId X) (ANum 0))
     THEN
       Y ::= ANum 0
     ELSE
       Y ::= ANum 42
     FI)
    (X ::= ANum 0;
     IFB (BEq (AId X) (ANum 0))
     THEN
       Y ::= AMinus (AId X) (AId X)   (* <--- changed here *)
     ELSE
       Y ::= ANum 42
     FI).
Proof.
  apply CSeq_congruence.
    apply refl_cequiv.
    apply CIf_congruence.
      apply refl_bequiv.
      apply CAss_congruence. unfold aequiv. simpl.
        symmetry. apply minus_diag.
      apply refl_cequiv.
Qed.

(* ####################################################### *)
(** * Case Study: Constant Folding *)

(** A _program transformation_ is a function that takes a program
    as input and produces some variant of the program as its
    output.  Compiler optimizations such as constant folding are
    a canonical example, but there are many others. *)

(* ####################################################### *)
(** ** Soundness of Program Transformations *)

(** A program transformation is _sound_ if it preserves the
    behavior of the original program.

    We can define a notion of soundness for translations of
    [aexp]s, [bexp]s, and [com]s. *)

Definition atrans_sound (atrans : aexp -> aexp) : Prop :=
  forall (a : aexp),
    aequiv a (atrans a).

Definition btrans_sound (btrans : bexp -> bexp) : Prop :=
  forall (b : bexp),
    bequiv b (btrans b).

Definition ctrans_sound (ctrans : com -> com) : Prop :=
  forall (c : com),
    cequiv c (ctrans c).

(* ######################################################## *)
(** ** The Constant-Folding Transformation *)

(** An expression is _constant_ when it contains no variable
    references.

    Constant folding is an optimization that finds constant
    expressions and replaces them by their values. *)

Fixpoint fold_constants_aexp (a : aexp) : aexp :=
  match a with
  | ANum n       => ANum n
  | AId i        => AId i
  | APlus a1 a2  =>
      match (fold_constants_aexp a1, fold_constants_aexp a2) with
      | (ANum n1, ANum n2) => ANum (n1 + n2)
      | (a1', a2') => APlus a1' a2'
      end
  | AMinus a1 a2 =>
      match (fold_constants_aexp a1, fold_constants_aexp a2) with
      | (ANum n1, ANum n2) => ANum (n1 - n2)
      | (a1', a2') => AMinus a1' a2'
      end
  | AMult a1 a2  =>
      match (fold_constants_aexp a1, fold_constants_aexp a2) with
      | (ANum n1, ANum n2) => ANum (n1 * n2)
      | (a1', a2') => AMult a1' a2'
      end
  end.

Example fold_aexp_ex1 :
    fold_constants_aexp
      (AMult (APlus (ANum 1) (ANum 2)) (AId X))
  = AMult (ANum 3) (AId X).
Proof. reflexivity. Qed.

(** Note that this version of constant folding doesn't eliminate
    trivial additions, etc. -- we are focusing attention on a single
    optimization for the sake of simplicity.  It is not hard to
    incorporate other ways of simplifying expressions; the definitions
    and proofs just get longer. *)

Example fold_aexp_ex2 :
    fold_constants_aexp
      (AMinus (AId X) (APlus (AMult (ANum 0) (ANum 6)) (AId Y)))
  = AMinus (AId X) (APlus (ANum 0) (AId Y)).
Proof. reflexivity. Qed.

(** Not only can we lift [fold_constants_aexp] to [bexp]s (in the
    [BEq] and [BLe] cases), we can also find constant _boolean_
    expressions and reduce them in-place. *)

Fixpoint fold_constants_bexp (b : bexp) : bexp :=
  match b with
  | BTrue        => BTrue
  | BFalse       => BFalse
  | BEq a1 a2  =>
      match (fold_constants_aexp a1, fold_constants_aexp a2) with
      | (ANum n1, ANum n2) => if beq_nat n1 n2 then BTrue else BFalse
      | (a1', a2') => BEq a1' a2'
      end
  | BLe a1 a2  =>
      match (fold_constants_aexp a1, fold_constants_aexp a2) with
      | (ANum n1, ANum n2) => if ble_nat n1 n2 then BTrue else BFalse
      | (a1', a2') => BLe a1' a2'
      end
  | BNot b1  =>
      match (fold_constants_bexp b1) with
      | BTrue => BFalse
      | BFalse => BTrue
      | b1' => BNot b1'
      end
  | BAnd b1 b2  =>
      match (fold_constants_bexp b1, fold_constants_bexp b2) with
      | (BTrue, BTrue) => BTrue
      | (BTrue, BFalse) => BFalse
      | (BFalse, BTrue) => BFalse
      | (BFalse, BFalse) => BFalse
      | (b1', b2') => BAnd b1' b2'
      end
  end.

Example fold_bexp_ex1 :
    fold_constants_bexp (BAnd BTrue (BNot (BAnd BFalse BTrue)))
  = BTrue.
Proof. reflexivity. Qed.

Example fold_bexp_ex2 :
    fold_constants_bexp
      (BAnd (BEq (AId X) (AId Y))
            (BEq (ANum 0)
                 (AMinus (ANum 2) (APlus (ANum 1) (ANum 1)))))
  = BAnd (BEq (AId X) (AId Y)) BTrue.
Proof. reflexivity. Qed.

(** To fold constants in a command, we apply the appropriate folding
    functions on all embedded expressions. *)

Fixpoint fold_constants_com (c : com) : com :=
  match c with
  | SKIP      =>
      SKIP
  | i ::= a  =>
      CAss i (fold_constants_aexp a)
  | c1 ; c2  =>
      (fold_constants_com c1) ; (fold_constants_com c2)
  | IFB b THEN c1 ELSE c2 FI =>
      match fold_constants_bexp b with
      | BTrue => fold_constants_com c1
      | BFalse => fold_constants_com c2
      | b' => IFB b' THEN fold_constants_com c1
                     ELSE fold_constants_com c2 FI
      end
  | WHILE b DO c END =>
      match fold_constants_bexp b with
      | BTrue => WHILE BTrue DO SKIP END
      | BFalse => SKIP
      | b' => WHILE b' DO (fold_constants_com c) END
      end
  end.

Example fold_com_ex1 :
  fold_constants_com
    (X ::= APlus (ANum 4) (ANum 5);
     Y ::= AMinus (AId X) (ANum 3);
     IFB BEq (AMinus (AId X) (AId Y)) (APlus (ANum 2) (ANum 4)) THEN
       SKIP
     ELSE
       Y ::= ANum 0
     FI;
     IFB BLe (ANum 0) (AMinus (ANum 4) (APlus (ANum 2) (ANum 1))) THEN
       Y ::= ANum 0
     ELSE
       SKIP
     FI;
     WHILE BEq (AId Y) (ANum 0) DO
       X ::= APlus (AId X) (ANum 1)
     END) =
  (X ::= ANum 9;
   Y ::= AMinus (AId X) (ANum 3);
   IFB BEq (AMinus (AId X) (AId Y)) (ANum 6) THEN
     SKIP
   ELSE
     (Y ::= ANum 0)
   FI;
   Y ::= ANum 0;
   WHILE BEq (AId Y) (ANum 0) DO
     X ::= APlus (AId X) (ANum 1)
   END).
Proof. reflexivity. Qed.

(* ################################################### *)
(** ** Soundness of Constant Folding *)

(** Now we need to show that what we've done is correct.  Here's
    the proof for arithmetic expressions: *)

Theorem fold_constants_aexp_sound :
  atrans_sound fold_constants_aexp.
Proof.
  unfold atrans_sound. intros a. unfold aequiv. intros st.
  aexp_cases (induction a) Case; simpl;
    (* ANum and AId follow immediately *)
    try reflexivity;
    (* APlus, AMinus, and AMult follow from the IH
       and the observation that
              aeval st (APlus a1 a2)
            = ANum ((aeval st a1) + (aeval st a2))
            = aeval st (ANum ((aeval st a1) + (aeval st a2)))
       (and similarly for AMinus/minus and AMult/mult) *)
    try (destruct (fold_constants_aexp a1);
         destruct (fold_constants_aexp a2);
         rewrite IHa1; rewrite IHa2; reflexivity). Qed.

(** **** Exercise: 3 stars, optional (fold_bexp_BEq_informal) *)
(** Here is an informal proof of the [BEq] case of the soundness
    argument for boolean expression constant folding.  Read it
    carefully and compare it to the formal proof that follows.  Then
    fill in the [BLe] case of the formal proof (without looking at the
    [BEq] case, if possible).

   _Theorem_: The constant folding function for booleans,
   [fold_constants_bexp], is sound.

   _Proof_: We must show that [b] is equivalent to [fold_constants_bexp],
   for all boolean expressions [b].  Proceed by induction on [b].  We
   show just the case where [b] has the form [BEq a1 a2].

   In this case, we must show
[[
       beval st (BEq a1 a2)
     = beval st (fold_constants_bexp (BEq a1 a2)).
]]
   There are two cases to consider:

     - First, suppose [fold_constants_aexp a1 = ANum n1] and
       [fold_constants_aexp a2 = ANum n2] for some [n1] and [n2].

       In this case, we have
[[
           fold_constants_bexp (BEq a1 a2)
         = if beq_nat n1 n2 then BTrue else BFalse
]]
       and
[[
           beval st (BEq a1 a2)
         = beq_nat (aeval st a1) (aeval st a2).
]]
       By the soundness of constant folding for arithmetic
       expressions (Lemma [fold_constants_aexp_sound]), we know
[[
           aeval st a1
         = aeval st (fold_constants_aexp a1)
         = aeval st (ANum n1)
         = n1
]]
       and
[[
           aeval st a2
         = aeval st (fold_constants_aexp a2)
         = aeval st (ANum n2)
         = n2,
]]
       so
[[
           beval st (BEq a1 a2)
         = beq_nat (aeval a1) (aeval a2)
         = beq_nat n1 n2.
]]
       Also, it is easy to see (by considering the cases [n1 = n2] and
       [n1 <> n2] separately) that
[[
           beval st (if beq_nat n1 n2 then BTrue else BFalse)
         = if beq_nat n1 n2 then beval st BTrue else beval st BFalse
         = if beq_nat n1 n2 then true else false
         = beq_nat n1 n2.
]]
       So
[[
           beval st (BEq a1 a2)
         = beq_nat n1 n2.
         = beval st (if beq_nat n1 n2 then BTrue else BFalse),
]]
       as required.

     - Otherwise, one of [fold_constants_aexp a1] and
       [fold_constants_aexp a2] is not a constant.  In this case, we
       must show
[[
           beval st (BEq a1 a2)
         = beval st (BEq (fold_constants_aexp a1)
                         (fold_constants_aexp a2)),
]]
       which, by the definition of [beval], is the same as showing
[[
           beq_nat (aeval st a1) (aeval st a2)
         = beq_nat (aeval st (fold_constants_aexp a1))
                   (aeval st (fold_constants_aexp a2)).
]]
       But the soundness of constant folding for arithmetic
       expressions ([fold_constants_aexp_sound]) gives us
[[
         aeval st a1 = aeval st (fold_constants_aexp a1)
         aeval st a2 = aeval st (fold_constants_aexp a2),
]]
       completing the case.  []
*)

Theorem fold_constants_bexp_sound:
  btrans_sound fold_constants_bexp.
Proof.
  unfold btrans_sound. intros b. unfold bequiv. intros st.
  bexp_cases (induction b) Case;
    (* BTrue and BFalse are immediate *)
    try reflexivity.
  Case "BEq".
    (* Doing induction when there are a lot of constructors makes
       specifying variable names a chore, but Coq doesn't always
       choose nice variable names.  We can rename entries in the
       context with the [rename] tactic: [rename a into a1] will
       change [a] to [a1] in the current goal and context. *)
    rename a into a1. rename a0 into a2. simpl.
    remember (fold_constants_aexp a1) as a1'.
    remember (fold_constants_aexp a2) as a2'.
    replace (aeval st a1) with (aeval st a1') by
       (subst a1'; rewrite <- fold_constants_aexp_sound; reflexivity).
    replace (aeval st a2) with (aeval st a2') by
       (subst a2'; rewrite <- fold_constants_aexp_sound; reflexivity).
    destruct a1'; destruct a2'; try reflexivity.
      (* The only interesting case is when both a1 and a2
         become constants after folding *)
      simpl. destruct (beq_nat n n0); reflexivity.
  Case "BLe".
    (* FILL IN HERE *) admit.
  Case "BNot".
    simpl. remember (fold_constants_bexp b) as b'.
    rewrite IHb.
    destruct b'; reflexivity.
  Case "BAnd".
    simpl.
    remember (fold_constants_bexp b1) as b1'.
    remember (fold_constants_bexp b2) as b2'.
    rewrite IHb1. rewrite IHb2.
    destruct b1'; destruct b2'; reflexivity.  Qed.
(** [] *)

(** **** Exercise: 3 stars (fold_constants_com_sound) *)
(** Complete the [WHILE] case of the following proof. *)

Theorem fold_constants_com_sound :
  ctrans_sound fold_constants_com.
Proof.
  unfold ctrans_sound. intros c.
  com_cases (induction c) Case; simpl.
  Case "SKIP". apply refl_cequiv.
  Case "::=". apply CAss_congruence. apply fold_constants_aexp_sound.
  Case ";". apply CSeq_congruence; assumption.
  Case "IFB".
    assert (bequiv b (fold_constants_bexp b)).
      SCase "Pf of assertion". apply fold_constants_bexp_sound.
    remember (fold_constants_bexp b) as b'.
    destruct b';
      (* If the optimization doesn't eliminate the if, then the result
         is easy to prove from the IH and fold_constants_bexp_sound *)
      try (apply CIf_congruence; assumption).
    SCase "b always true".
      apply trans_cequiv with c1; try assumption.
      apply IFB_true; assumption.
    SCase "b always false".
      apply trans_cequiv with c2; try assumption.
      apply IFB_false; assumption.
  Case "WHILE".
    (* FILL IN HERE *) Admitted.
(** [] *)

(* ########################################################## *)
(** *** Soundness of (0 + n) Elimination, Redux *)

(** **** Exercise: 4 stars, optional (optimize_0plus) *)
(** Recall the definition [optimize_0plus] from Imp.v:
[[
    Fixpoint optimize_0plus (e:aexp) : aexp :=
      match e with
      | ANum n =>
          ANum n
      | APlus (ANum 0) e2 =>
          optimize_0plus e2
      | APlus e1 e2 =>
          APlus (optimize_0plus e1) (optimize_0plus e2)
      | AMinus e1 e2 =>
          AMinus (optimize_0plus e1) (optimize_0plus e2)
      | AMult e1 e2 =>
          AMult (optimize_0plus e1) (optimize_0plus e2)
      end.
]]
   Note that this function is defined over the old [aexp]s,
   without states.

   Write a new version of this function that accounts for variables,
   and analogous ones for [bexp]s and commands:
[[
     optimize_0plus_aexp
     optimize_0plus_bexp
     optimize_0plus_com
]]
   Prove that these three functions are sound, as we did for
   [fold_constants_*].  Make sure you use the congruence lemmas in
   the proof of [optimize_0plus_com] (otherwise it will be _long_!).

   Then define an optimizer on commands that first folds
   constants (using [fold_constants_com]) and then eliminates [0 + n]
   terms (using [optimize_0plus_com]).

   - Give a meaningful example of this optimizer's output.

   - Prove that the optimizer is sound.  (This part should be _very_
     easy.)  *)

(* FILL IN HERE *)
(** [] *)

(* ####################################################### *)
(** * Proving That Programs Are _Not_ Equivalent *)

(** Suppose that [c1] is a command of the form [X ::= a1; Y ::= a2]
    and [c2] is the command [X ::= a1; Y ::= a2'], where [a2'] is
    formed by substituting [a1] for all occurrences of [X] in [a2].
    For example, [c1] and [c2] might be:
[[
       c1  =  (X ::= 42 + 53;
               Y ::= Y + X)
       c2  =  (X ::= 42 + 53;
               Y ::= Y + (42 + 53))
]]
    Clearly, this particular [c1] and [c2] are equivalent.  But is
    this true in general? *)

(** We will see in a moment that it is not, but it is worthwhile
    to pause, now, and see if you can find a counter-example on your
    own (or remember the one from the discussion in class). *)

(** Here, formally, is the function that substitutes an arithmetic
    expression for each occurrence of a given variable in another
    expression: *)

Fixpoint subst_aexp (i : id) (u : aexp) (a : aexp) : aexp :=
  match a with
  | ANum n       => ANum n
  | AId i'       => if beq_id i i' then u else AId i'
  | APlus a1 a2  => APlus (subst_aexp i u a1) (subst_aexp i u a2)
  | AMinus a1 a2 => AMinus (subst_aexp i u a1) (subst_aexp i u a2)
  | AMult a1 a2  => AMult (subst_aexp i u a1) (subst_aexp i u a2)
  end.

Example subst_aexp_ex :
  subst_aexp X (APlus (ANum 42) (ANum 53)) (APlus (AId Y) (AId X)) =
  (APlus (AId Y) (APlus (ANum 42) (ANum 53))).
Proof. reflexivity.  Qed.

(** And here is the property we are interested in, expressing the
    claim that commands [c1] and [c2] as described above are
    always equivalent.  *)

Definition subst_equiv_property := forall i1 i2 a1 a2,
  cequiv (i1 ::= a1; i2 ::= a2)
         (i1 ::= a1; i2 ::= subst_aexp i1 a1 a2).

(** Sadly, the property does _not_ always hold.

    _Theorem_: It is not the case that, for all [i1], [i2], [a1],
    and [a2],
[[
         cequiv (i1 ::= a1; i2 ::= a2)
                (i1 ::= a1; i2 ::= subst_aexp i1 a1 a2).
]]
    _Proof_: Suppose, for a contradiction, that for all [i1], [i2],
    [a1], and [a2], we have
[[
      cequiv (i1 ::= a1; i2 ::= a2)
             (i1 ::= a1; i2 ::= subst_aexp i1 a1 a2).
]]
    Consider the following program:
[[
         X ::= APlus (AId X) (ANum 1); Y ::= AId X
]]
    Note that
[[
         (X ::= APlus (AId X) (ANum 1); Y ::= AId X)
         / empty_state || st1,
]]
    where [st1 = { X |-> 1, Y |-> 1 }].

    By our assumption, we know that
[[
        cequiv (X ::= APlus (AId X) (ANum 1); Y ::= AId X)
               (X ::= APlus (AId X) (ANum 1); Y ::= APlus (AId X) (ANum 1))
]]
    so, by the definition of [cequiv], we have
[[
        (X ::= APlus (AId X) (ANum 1); Y ::= APlus (AId X) (ANum 1))
        / empty_state || st1.
]]
    But we can also derive
[[
        (X ::= APlus (AId X) (ANum 1); Y ::= APlus (AId X) (ANum 1))
        / empty_state || st2,
]]
    where [st2 = { X |-> 1, Y |-> 2 }].  Note that [st1 <> st2]; this
    is a contradiction, since [ceval] is deterministic!  [] *)

Theorem subst_inequiv :
  ~ subst_equiv_property.
Proof.
  unfold subst_equiv_property.
  intros Contra.

  (* Here is the counterexample: assuming that [subst_equiv_property]
     holds allows us to prove that these two programs are
     equivalent... *)
  remember (X ::= APlus (AId X) (ANum 1);
            Y ::= AId X)
      as c1.
  remember (X ::= APlus (AId X) (ANum 1);
            Y ::= APlus (AId X) (ANum 1))
      as c2.
  assert (cequiv c1 c2) by (subst; apply Contra).

  (* ... allows us to show that the command [c2] can terminate
     in two different final states:
        st1 = {X |-> 1, Y |-> 1}
        st2 = {X |-> 1, Y |-> 2}. *)
  remember (update (update empty_state X 1) Y 1) as st1.
  remember (update (update empty_state X 1) Y 2) as st2.
  assert (H1: c1 / empty_state || st1);
  assert (H2: c2 / empty_state || st2);
  try (subst;
       apply E_Seq with (st' := (update empty_state X 1));
       apply E_Ass; reflexivity).
  apply H in H1.

  (* Finally, we use the fact that evaluation is deterministic
     to obtain a contradiction. *)
  assert (Hcontra: st1 = st2)
    by (apply (ceval_deterministic c2 empty_state); assumption).
  assert (Hcontra': st1 Y = st2 Y)
    by (rewrite Hcontra; reflexivity).
  subst. inversion Hcontra'.  Qed.

(** **** Exercise: 4 stars (better_subst_equiv) *)
(** The equivalence we had in mind above was not complete nonsense --
    it was actually almost right.  To make it correct, we just need to
    exclude the case where the variable [X] occurs in the
    right-hand-side of the first assignment statement. *)

Inductive var_not_used_in_aexp (X:id) : aexp -> Prop :=
  | VNUNum: forall n, var_not_used_in_aexp X (ANum n)
  | VNUId: forall Y, X <> Y -> var_not_used_in_aexp X (AId Y)
  | VNUPlus: forall a1 a2,
      var_not_used_in_aexp X a1 ->
      var_not_used_in_aexp X a2 ->
      var_not_used_in_aexp X (APlus a1 a2)
  | VNUMinus: forall a1 a2,
      var_not_used_in_aexp X a1 ->
      var_not_used_in_aexp X a2 ->
      var_not_used_in_aexp X (AMinus a1 a2)
  | VNUMult: forall a1 a2,
      var_not_used_in_aexp X a1 ->
      var_not_used_in_aexp X a2 ->
      var_not_used_in_aexp X (AMult a1 a2).

Lemma aeval_weakening : forall i st a ni,
  var_not_used_in_aexp i a ->
  aeval (update st i ni) a = aeval st a.
Proof.
  (* FILL IN HERE *) Admitted.

(** Using [var_not_used_in_aexp], formalize and prove a correct verson
    of [subst_equiv_property]. *)

(* FILL IN HERE *)
(** [] *)

(** **** Exercise: 3 stars, recommended (inequiv_exercise) *)
Theorem inequiv_exercise:
  ~ cequiv (WHILE BTrue DO SKIP END) SKIP.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ####################################################### *)
(** * Doing Without Extensionality (Optional) *)

(** Purists might object to using the [functional_extensionality]
    axiom.  In general, it can be quite dangerous to add axioms,
    particularly several at once (as they may be mutually
    inconsistent). In fact, [functional_extensionality] and
    [excluded_middle] can both be assumed without any problems, but
    some Coq users prefer to avoid such "heavyweight" general
    techniques, and instead craft solutions for specific problems that
    stay within Coq's standard logic.

    For our particular problem here, rather than extending the
    definition of equality to do what we want on functions
    representing states, we could instead give an explicit notion of
    _equivalence_ on states.  For example: *)

Definition stequiv (st1 st2 : state) : Prop :=
  forall (X:id), st1 X = st2 X.

Notation "st1 '~' st2" := (stequiv st1 st2) (at level 30).

(** It is easy to prove that [stequiv] is an _equivalence_ (i.e., it
   is reflexive, symmetric, and transitive), so it partitions the set
   of all states into equivalence classes. *)

(** **** Exercise: 1 star, optional (stequiv_refl) *)
Lemma stequiv_refl : forall (st : state),
  st ~ st.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 1 star, optional (stequiv_sym) *)
Lemma stequiv_sym : forall (st1 st2 : state),
  st1 ~ st2 ->
  st2 ~ st1.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 1 star, optional (stequiv_trans) *)
Lemma stequiv_trans : forall (st1 st2 st3 : state),
  st1 ~ st2 ->
  st2 ~ st3 ->
  st1 ~ st3.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Another useful fact... *)
(** **** Exercise: 1 star, optional (stequiv_update) *)
Lemma stequiv_update : forall (st1 st2 : state),
  st1 ~ st2 ->
  forall (X:id) (n:nat),
  update st1 X n ~ update st2 X n.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** It is then straightforward to show that [aeval] and [beval] behave
    uniformly on all members of an equivalence class: *)

(** **** Exercise: 2 stars, optional (stequiv_aeval) *)
Lemma stequiv_aeval : forall (st1 st2 : state),
  st1 ~ st2 ->
  forall (a:aexp), aeval st1 a = aeval st2 a.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, optional (stequiv_beval) *)
Lemma stequiv_beval : forall (st1 st2 : state),
  st1 ~ st2 ->
  forall (b:bexp), beval st1 b = beval st2 b.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** We can also characterize the behavior of [ceval] on equivalent
    states (this result is a bit more complicated to write down
    because [ceval] is a relation). *)

Lemma stequiv_ceval: forall (st1 st2 : state),
  st1 ~ st2 ->
  forall (c: com) (st1': state),
    (c / st1 || st1') ->
    exists st2' : state,
    ((c / st2 || st2') /\  st1' ~ st2').
Proof.
  intros st1 st2 STEQV c st1' CEV1. generalize dependent st2.
  induction CEV1; intros st2 STEQV.
  Case "SKIP".
    exists st2. split.
      constructor.
      assumption.
  Case ":=".
    exists (update st2 l n). split.
       constructor.  rewrite <- H. symmetry.  apply stequiv_aeval.
       assumption. apply stequiv_update.  assumption.
  Case ";".
    destruct (IHCEV1_1 st2 STEQV) as [st2' [P1 EQV1]].
    destruct (IHCEV1_2 st2' EQV1) as [st2'' [P2 EQV2]].
    exists st2''.  split.
      apply E_Seq with st2';  assumption.
      assumption.
  Case "IfTrue".
    destruct (IHCEV1 st2 STEQV) as [st2' [P EQV]].
    exists st2'.  split.
      apply E_IfTrue.  rewrite <- H. symmetry. apply stequiv_beval.
      assumption. assumption. assumption.
  Case "IfFalse".
    destruct (IHCEV1 st2 STEQV) as [st2' [P EQV]].
    exists st2'. split.
     apply E_IfFalse. rewrite <- H. symmetry. apply stequiv_beval.
     assumption.  assumption. assumption.
  Case "WhileEnd".
    exists st2. split.
      apply E_WhileEnd. rewrite <- H. symmetry. apply stequiv_beval.
      assumption. assumption.
  Case "WhileLoop".
    destruct (IHCEV1_1 st2 STEQV) as [st2' [P1 EQV1]].
    destruct (IHCEV1_2 st2' EQV1) as [st2'' [P2 EQV2]].
    exists st2''. split.
      apply E_WhileLoop with st2'.  rewrite <- H. symmetry.
      apply stequiv_beval. assumption. assumption. assumption.
      assumption.
Qed.

(** Now we need to redefine [cequiv] to use [~] instead of [=].  It is
    not completely trivial to do this in a way that keeps the
    definition simple and symmetric, but here is one approach (thanks
    to Andrew McCreight). We first define a looser variant of [||]
    that "folds in" the notion of equivalence. *)

Reserved Notation "c1 '/' st '||'' st'" (at level 40, st at level 39).

Inductive ceval' : com -> state -> state -> Prop :=
  | E_equiv : forall c st st' st'',
    c / st || st' ->
    st' ~ st'' ->
    c / st ||' st''
  where   "c1 '/' st '||'' st'" := (ceval' c1 st st').

(** Now the revised definition of [cequiv'] looks familiar: *)

Definition cequiv' (c1 c2 : com) : Prop :=
  forall (st st' : state),
    (c1 / st ||' st') <-> (c2 / st ||' st').

(** A sanity check shows that the original notion of command
   equivalence is at least as strong as this new one.  (The converse
   is not true, naturally.) *)

Lemma cequiv__cequiv' : forall (c1 c2: com),
  cequiv c1 c2 -> cequiv' c1 c2.
Proof.
  unfold cequiv, cequiv'; split; intros.
    inversion H0 ; subst.  apply E_equiv with st'0.
    apply (H st st'0); assumption. assumption.
    inversion H0 ; subst.  apply E_equiv with st'0.
    apply (H st st'0). assumption. assumption.
Qed.

(** **** Exercise: 2 stars, optional (identity_assignment') *)
(** Finally, here is our example once more... (You can complete the
    proof.) *)

Example identity_assignment' :
  cequiv' SKIP (X ::= AId X).
Proof.
    unfold cequiv'.  intros.  split; intros.
    Case "->".
      inversion H; subst; clear H. inversion H0; subst.
      apply E_equiv with (update st'0 X (st'0 X)).
      constructor. reflexivity.  apply stequiv_trans with st'0.
      unfold stequiv. intros. apply update_same.
      reflexivity. assumption.
    Case "<-".
      (* FILL IN HERE *) Admitted.
(** [] *)

(** On the whole, this explicit equivalence approach is considerably
    harder to work with than relying on functional
    extensionality. (Coq does have an advanced mechanism called
    "setoids" that makes working with equivalences somewhat easier, by
    allowing them to be registered with the system so that standard
    rewriting tactics work for them almost as well as for equalities.)
    But it is worth knowing about, because it applies even in
    situations where the equivalence in question is _not_ over
    functions.  For example, if we chose to represent state mappings
    as binary search trees, we would need to use an explicit
    equivalence of this kind. *)

(* ####################################################### *)
(** * Additional Exercises *)

(** **** Exercise: 4 stars, optional (for_while_equiv) *)
(** This exercise extends the optional add_for_loop exercise from
    Imp.v, where you were asked to extend the language of commands
    with C-style [for] loops.  Prove that the command:
[[
      for (c1 ; b ; c2) {
          c3
      }
]]
    is equivalent to:
[[
       c1 ;
       WHILE b DO
         c3 ;
         c2
       END
]]
*)
(* FILL IN HERE *)
(** [] *)

(** **** Exercise: 3 stars, optional (swap_noninterfering_assignments) *)
Theorem swap_noninterfering_assignments: forall l1 l2 a1 a2,
  l1 <> l2 ->
  var_not_used_in_aexp l1 a2 ->
  var_not_used_in_aexp l2 a1 ->
  cequiv
    (l1 ::= a1; l2 ::= a2)
    (l2 ::= a2; l1 ::= a1).
Proof.
(* Hint: You'll need [functional_extensionality] *)
(* FILL IN HERE *) Admitted.
(** [] *)


Require Import
        Coq.Lists.SetoidList
        Fiat.QueryStructure.Specification.Representation.QueryStructureNotations.

Open Scope list_scope.

Section PrefixClauses.
  Context {X : Type}
          {X_Qeq : Query_eq X}.

  Definition Prefix (X_eq : X -> X -> Prop)
             (s s' : list X) :=
    exists s'', eqlistA X_eq (s ++ s'') s'.

  Definition IsPrefix (x st : list X) : Prop := @Prefix eq x st.

  Fixpoint Prefix_dec
           {X_eq : X -> X -> Prop}
           (X_eq_dec : forall x x', {X_eq x x'} + {~ X_eq x x'})
           {X_refl : Reflexive X_eq}
           (p s : list X) : {Prefix X_eq p s} + {~ Prefix X_eq p s}.
  refine (match p, s with
            | nil, _ => left _
            | p' :: ps, s' :: ss =>
              if X_eq_dec p' s' then
                if Prefix_dec X_eq X_eq_dec _ ps ss then
                  left _
                else
                  right _
              else
                right _
            | _, _ => right _
          end);  intuition; [
    eexists; intuition |
    inject H |
    let _H0 := match goal with H : ?R _ _ |- _ => constr:(H) end in
    destruct _H0; eexists; simpl; subst |
    let _H0 := match goal with H : ?R _ _ -> False |- _ => constr:(H) end in
    apply _H0; inject H; inversion H0; eexists |
    inject H; simpl in H0; inversion H0 ]; eauto.
  inversion H0.
  Defined.

  Definition IsPrefix_dec
    : forall (p s : list X), {IsPrefix p s} + {~ IsPrefix p s}
  := @Prefix_dec _ A_eq_dec (fun a => eq_refl a).
  Ltac prefix_crush := intros; find_if_inside; intuition eauto; discriminate.

  Instance DecideableEnsemble_HasPrefix st :
    DecideableEnsemble (IsPrefix st).
  Proof.
    econstructor 1 with (dec := fun a => ?[IsPrefix_dec st a]).
    prefix_crush.
  Defined.

  Global Instance DecideableEnsemble_HasPrefix_f
         (A : Type)
         (f : A -> list X)
         b :
    DecideableEnsemble (fun a => IsPrefix b (f a)).
  Proof.
    econstructor 1 with (dec := fun a => ?[IsPrefix_dec b (f a)]).
    prefix_crush.
  Defined.

  Instance DecideableEnsemble_FindPrefix st :
    DecideableEnsemble (fun a => IsPrefix a st).
  Proof.
    econstructor 1 with (dec := fun a =>  ?[IsPrefix_dec a st]).
    prefix_crush.
  Defined.

  Global Instance DecideableEnsemble_FindPrefix_f
         (A : Type)
         (f : A -> list X)
         b :
    DecideableEnsemble (fun a => IsPrefix (f a) b).
  Proof.
    econstructor 1 with (dec := fun a => ?[IsPrefix_dec (f a) b]).
    prefix_crush.
  Defined.

End PrefixClauses.


From CompCert Require Import Coqlib.
From Utils    Require Import Defns.
Require Import Relations.
Close Scope Z.
Set Implicit Arguments.

(** * 1 Closures of small step semantics' steps *)

Section CLOSURES.

Variable (genv state: Type) (step : genv -> state -> state -> Prop).

Definition nostep (ge: genv) (s: state) : Prop :=
forall s', ~ step ge s s'.

(** Kleene (reflexive, transitive) closures over steps *)

Inductive star (ge: genv): state -> state -> Prop :=
  | star_refl : forall s,
      star ge s s
  | one_star_star : forall s1 s2 s3,
      step ge s1 s2 -> star ge s2 s3 -> star ge s1 s3.

Lemma star_one: forall ge s1 s2,
  step ge s1 s2 -> star ge s1 s2.
Proof.
  intros. eapply one_star_star; eauto.
  left.
Qed.

Lemma star_two:
  forall ge s1 s2 s3,
  step ge s1 s2 -> step ge s2 s3 ->
  star ge s1 s3.
Proof.
  intros. eapply one_star_star; eauto.
  apply star_one; auto.
Qed.

Lemma star_three:
  forall ge s1 s2 s3 s4,
  step ge s1 s2 -> step ge s2 s3 ->
  step ge s3 s4 -> star ge s1 s4.
Proof.
  intros. eapply one_star_star; eauto.
  eapply star_two; eauto.
Qed.

Lemma star_four:
  forall ge s1 s2 s3 s4 s5,
  step ge s1 s2 -> step ge s2 s3 ->
  step ge s3 s4 -> step ge s4 s5 ->
  star ge s1 s5.
Proof.
  intros. eapply one_star_star; eauto.
  eapply star_three; eauto.
Qed.

Lemma star_trans:
  forall ge s1 s2 (X:star ge s1 s2)
  s3 (Y:star ge s2 s3),
  star ge s1 s3.
Proof with eauto.
  induction 1; intros...
  eapply one_star_star...
Qed.

(* Lemma one_star_star:
  forall ge s1 s2 s3,
  step ge s1 s2 -> star ge s2 s3 ->
  star ge s1 s3.
Proof one_star_star. *)

Lemma star_one_star:
  forall ge s1 s2 s3
  (X:star ge s1 s2) (H:step ge s2 s3),
  star ge s1 s3.
Proof with eauto.
  intros. eapply star_trans;
  [|apply star_one]...
Qed.

(** Irreflexive, transitive closures over steps *)

Inductive plus (ge: genv) : state -> state -> Prop :=
  | one_star_plus: forall s1 s2 s3,
      step ge s1 s2 -> star ge s2 s3 -> plus ge s1 s3.

Lemma plus_one: forall ge s1 s2,
  step ge s1 s2 -> plus ge s1 s2.
Proof.
  intros. apply one_star_plus with s2;[auto|left].
Qed.

Lemma plus_star: forall ge s1 s2,
  plus ge s1 s2 -> star ge s1 s2.
Proof.
  inversion 1; subst.
  eapply one_star_star; eauto.
Qed.

Lemma star_one_plus: forall ge s1 s2 s3
  (X:star ge s1 s2) (H:step ge s2 s3),
  plus ge s1 s3.
Proof.
  intros. inv X;
  [ apply plus_one
  | eapply one_star_plus, star_one_star
  ]; eauto.
Qed.

Lemma one_plus_plus: forall ge s1 s2 s3
  (H:step ge s1 s2) (X:plus ge s2 s3),
  plus ge s1 s3.
Proof with eauto.
  intros. inv X.
  eapply one_star_plus...
  apply plus_star.
  eapply one_star_plus...
Qed.

Lemma one_one_plus: forall ge s1 s2 s3
  (H:step ge s1 s2) (X:step ge s2 s3),
  plus ge s1 s3.
Proof with eauto.
  intros. econstructor...
  eapply star_one...
Qed.

Lemma plus_one_plus: forall ge s1 s2 s3
  (X:plus ge s1 s2) (H:step ge s2 s3),
  plus ge s1 s3.
Proof with eauto.
  intros. eapply star_one_plus...
  apply plus_star...
Qed.

Lemma plus_star_plus: forall ge s1 s2 s3
  (X:plus ge s1 s2) (Y:star ge s2 s3), plus ge s1 s3.
Proof with eauto.
  intros. inv X...
  econstructor...
  eapply star_trans...
Qed.

Lemma star_plus_plus: forall ge s1 s2 s3
  (X:star ge s1 s2) (Y:plus ge s2 s3), plus ge s1 s3.
Proof with eauto.
  intros. inv Y...
  eapply plus_star_plus;
  [eapply star_one_plus|]...
Qed.

Lemma plus_star_star: forall ge s1 s2 s3,
  plus ge s1 s2 -> star ge s2 s3 -> star ge s1 s3.
Proof with eauto.
  intros. eapply plus_star, plus_star_plus...
Qed.

Lemma star_plus_star: forall ge s1 s2 s3,
  star ge s1 s2 -> plus ge s2 s3 -> star ge s1 s3.
Proof with eauto.
  intros. eapply plus_star, star_plus_plus...
Qed.

Lemma plus_trans: forall ge s1 s2
  (X:plus ge s1 s2) s3 (Y:plus ge s2 s3), plus ge s1 s3.
Proof with eauto.
  intros. eapply plus_star_plus...
  apply plus_star...
Qed.

Lemma plus_inv: forall ge s1 s2,
  plus ge s1 s2 ->
    step ge s1 s2 \/
    exists s', step ge s1 s' /\ plus ge s' s2.
Proof with eauto.
  inversion 1; subst.
  inversion H1; subst.
  - left...
  - right. exists s3.
    split...
    econstructor...
Qed.

Lemma star_inv: forall ge s1 s2,
  star ge s1 s2 -> s2 = s1 \/ plus ge s1 s2.
Proof.
  induction 1; [left|right];
  econstructor; eauto.
Qed.

Lemma plus_ind2:
  forall ge (P: state -> state -> Prop),
  (forall S1 S2, step ge S1 S2 -> P S1 S2) ->
  (forall S1 S2 S3,
    step ge S1 S2 -> plus ge S2 S3 -> P S2 S3 -> P S1 S3) ->
  forall S1 S2, plus ge S1 S2 -> P S1 S2.
Proof with eauto.
  intros ge P BASE IND.
  assert (forall s1 s2, star ge s1 s2 ->
          forall s0, step ge s0 s1 ->
          P s0 s2).
  induction 1; intros.
  apply BASE...
  eapply IND...
  econstructor...
  intros. inv H0...
Qed.

CoInductive forever (ge: genv): state -> Prop :=
  | forever_intro: forall s1 s2,
      step ge s1 s2 -> forever ge s2 ->
      forever ge s1.

Lemma star_forever: forall ge s1 s2, star ge s1 s2 ->
  forever ge s2 -> forever ge s1.
Proof with eauto.
  induction 1; intros; simpl...
  econstructor...
Qed.

Remark cycle_forever: forall ge st,
  step ge st st -> forever ge st.
Proof.
  intros. cofix X.
  apply (@forever_intro ge st st); assumption.
Qed.

Lemma forever_coinduction_principle:
  forall (ge: genv) (P: state -> Prop),
  (forall st, P st -> exists st', step ge st st' /\ P st') ->
  forall st, P st -> forever ge st.
Proof.
  intros ge P IH. cofix CoIH; intros.
  destruct (IH st H) as [st' [Hstep H']].
  apply forever_intro with st'; auto.
Qed.

Lemma forever_coinduction_principle_plus:
  forall (ge: genv) (P: state -> Prop),
  (forall st, P st -> exists st', plus ge st st' /\ P st') ->
  forall st, P st -> forever ge st.
Proof with auto.
  intros.
  apply forever_coinduction_principle with
    (P := fun st => exists st', star ge st st' /\ P st').
  clear H0 st.
  - intros st [st' [Hstar Hst']].
    inversion Hstar as [|a s1 b]; subst.
    + destruct (H st' Hst') as [st2 [Hplus Hst2]].
      inversion Hplus as [a st1 b H1 H2 A B]; subst a b.
      exists st1. split;[|exists st2]...
    + exists s1 . split;[|exists st']...
  - exists st; split... left.
Qed.

Inductive starN (ge: genv): nat -> state -> state -> Prop :=
  | starN_refl: forall s,
      starN ge O s s
  | starN_step: forall n s s' s'',
      step ge s s' -> starN ge n s' s'' -> starN ge (S n) s s''.

Remark starN_star: forall ge n s s',
  starN ge n s s' -> star ge s s'.
Proof.
  induction 1; econstructor; eauto.
Qed.

Remark star_starN: forall ge s s',
  star ge s s' -> exists n, starN ge n s s'.
Proof.
  induction 1 as [|s1 s2 s3 Hstp Hstr [n IH]];
  [ exists 0
  | exists (S n)];
  econstructor; eauto.
Qed.

Variable A: Type.
Variable order: A -> A -> Prop.

CoInductive forever_N (ge: genv) : A -> state -> Prop :=
  | forever_N_star: forall s1 s2 a1 a2,
      star ge s1 s2 ->
      order a2 a1 ->
      forever_N ge a2 s2 ->
      forever_N ge a1 s1
  | forever_N_plus: forall s1 s2 a1 a2,
      plus ge s1 s2 ->
      forever_N ge a2 s2 ->
      forever_N ge a1 s1.

Hypothesis order_wf: well_founded order.

Lemma forever_N_inv: forall ge a s,
  forever_N ge a s ->
  exists s', exists a',
    step ge s s' /\ forever_N ge a' s'.
Proof with eauto.
  intros ge a0. pattern a0. apply (well_founded_ind order_wf).
  intros. inv H0.
  (* star case *)
  inv H1.
  (* no transition *)
  apply H with a2... auto. auto.
  (* at least one transition *)
  exists s0. exists x. split. auto. eapply forever_N_star...
  (* plus case *)
  inv H1. exists s0; exists a2. split...
  inv H3... eapply forever_N_plus...
  econstructor...
Qed.

Lemma forever_N_forever: forall ge a s,
  forever_N ge a s -> forever ge s.
Proof.
  cofix CoIH; intros.
  destruct (forever_N_inv H) as [s' [a' [P Q]]].
  apply forever_intro with s'. auto.
  apply CoIH with a'; auto.
Qed.

CoInductive forever_plus (ge: genv) : state -> Prop :=
  | forever_plus_intro: forall s1 s2,
      plus ge s1 s2 ->
      forever_plus ge s2 ->
      forever_plus ge s1.

Lemma forever_plus_inv: forall ge s,
  forever_plus ge s ->
  exists s', step ge s s' /\ forever_plus ge s'.
Proof.
  intros. inv H. inv H0. exists s0. split; auto.
  exploit star_inv; eauto. intros [P | R].
  subst. auto. econstructor; eauto.
Qed.

Lemma forever_plus_forever: forall ge s,
  forever_plus ge s -> forever ge s.
Proof.
  cofix COIH; intros.
  destruct (forever_plus_inv H) as [s' [P Q]].
  econstructor; eauto.
Qed.

End CLOSURES.

Record semantics : Type := Semantics_gen {
  state: Type;
  genvtype: Type;
  value: Type;
  error: Type;
  step: genvtype -> state -> state -> Prop;
  initial_state: state -> Prop;
  final_state: state -> value -> Prop;
  error_state: state -> error -> Prop;
  fin_err_disjoint: forall s res err,
    ~(final_state s res /\ error_state s err);
  globalenv: genvtype
}.

Declare Scope smallstep_scope.
Notation " 'Step' L " :=
    (step L (L.(globalenv))) (at level 1) : smallstep_scope.
Notation " 'Star' L " :=
    (star (L.(step)) (L.(globalenv))) (at level 1) : smallstep_scope.
Notation " 'Plus' L " :=
    (plus (L.(step)) (L.(globalenv))) (at level 1) : smallstep_scope.
Notation " 'Nostep' L " :=
    (nostep (L.(step)) (L.(globalenv))) (at level 1) : smallstep_scope.
Notation " 'Forever' L" :=
    (forever (L.(step)) (L.(globalenv))) (at level 1) : smallstep_scope.

Open Scope smallstep_scope.

Record determinate (L: semantics) : Prop := Determinate {
  sd_determ: forall s s1 s2,
    Step L s s1 -> Step L s s2 -> s1 = s2;
  sd_initial_determ: forall s1 s2,
    initial_state L s1 -> initial_state L s2 -> s1 = s2;
  sd_final_nostep: forall s res,
    final_state L s res -> Nostep L s;
  sd_final_determ: forall s r1 r2,
    final_state L s r1 -> final_state L s r2 -> r1 = r2;
  sd_error_nostep: forall s err,
    error_state L s err -> Nostep L s;
  sd_error_determ: forall s e1 e2,
    error_state L s e1 -> error_state L s e2 -> e1 = e2
}.

Section DETERMINACY.
Variable L: semantics.
Hypothesis DET: determinate L.

Lemma star_determinacy:
  forall s s', Star L s s' ->
  forall s'', Star L s s'' -> Star L s' s'' \/ Star L s'' s'.
Proof with eauto.
  induction 1; intros s5;
  [ intros star_s_s5
  | intros star_s1_s5]...
  inv star_s1_s5.
  - right. eapply one_star_star...
  - apply IHstar.
    erewrite (sd_determ DET _ _ _ H H1)...
Qed.

End DETERMINACY.

Definition safe (L: semantics) (s: L.(state)) : Prop :=
  forall s', Star L s s' ->
    (exists res, final_state L s' res)
 \/ (exists err, error_state L s' err)
 \/ (exists s'', Step L s' s'').

Lemma star_safe:
  forall (L: semantics) s s',
  Star L s s' -> safe L s -> safe L s'.
Proof.
  intros L s1 s2 star12 safe1; red;
  intros s3 star23. apply safe1.
  eapply star_trans; eauto.
Qed.

Definition matching_of (A: semantics -> Type) (L1 L2: semantics) := A L1 -> A L2 -> Prop.

Record fsim_properties
      (L1 L2: semantics) (index: Type)
      (order: index -> index -> Prop)
      (match_value :  matching_of value L1 L2)
      (match_error :  matching_of error L1 L2)
      (match_states: (matching_of value L1 L2) ->
                     (matching_of error L1 L2) -> index -> (matching_of state L1 L2))
      : Prop := {
  fsim_order_wf: well_founded order;
  fsim_match_initial_states:
    forall s1, initial_state L1 s1 ->
    exists i, exists s2, initial_state L2 s2 /\ match_states match_value match_error i s1 s2;
  fsim_match_final_states:
    forall i s1 s2 r1,
    match_states match_value match_error i s1 s2 ->
    final_state L1 s1 r1 ->
    exists r2, final_state L2 s2 r2 /\ match_value r1 r2;
  fsim_match_error_states:
    forall i s1 s2 e1,
    match_states match_value match_error i s1 s2 ->
    error_state L1 s1 e1 ->
    exists e2, error_state L2 s2 e2 /\ match_error e1 e2;
  fsim_simulation:
    forall s1 s1', Step L1 s1 s1' ->
    forall i s2, match_states match_value match_error i s1 s2 ->
    exists i' s2',
      (Plus L2 s2 s2' \/ (Star L2 s2 s2' /\ order i' i))
    /\ match_states match_value match_error i' s1' s2';
}.

Arguments fsim_properties: clear implicits.

Inductive forward_simulation (L1 L2: semantics)
(match_values : matching_of value L1 L2)
(match_errors : matching_of error L1 L2) : Prop :=
  Forward_simulation
      (index: Type)
      (order: index -> index -> Prop)
      (match_states: (matching_of value L1 L2) ->
                     (matching_of error L1 L2) -> index -> (matching_of state L1 L2))
      (props: fsim_properties L1 L2 index order match_values match_errors match_states).

Arguments forward_simulation L1 L2 match_values match_errors : clear implicits.
Arguments Forward_simulation L1 L2 match_values match_errors {index} order match_states props.

Lemma fsim_simulation':
  forall L1 L2 index order match_values match_errors match_states,
  fsim_properties L1 L2 index order match_values match_errors match_states ->
  forall i s1 s1', Step L1 s1 s1' ->
  forall s2, match_states match_values match_errors i s1 s2 ->
  (exists i', exists s2', Plus L2 s2 s2' /\ match_states match_values match_errors i' s1' s2')
  \/ (exists i', order i' i /\ match_states match_values match_errors i' s1' s2).
Proof with eauto.
  intros. exploit fsim_simulation...
  intros [i' [s2' [A B]]]. intuition.
  - left; exists i', s2'...
  - inv H3.
    + right; exists i'...
    + left; exists i', s2'; split... econstructor...
Qed.

Section FORWARD_SIMU_DIAGRAMS.

Variable L1 L2: semantics.

Variable match_values : matching_of value L1 L2.
Variable match_errors : matching_of error L1 L2.
Variable match_states : matching_of value L1 L2 ->
                        matching_of error L1 L2 ->
                        matching_of state L1 L2.

Hypothesis match_initial_states:
  forall s1, initial_state L1 s1 ->
  exists s2, initial_state L2 s2 /\ match_states match_values match_errors s1 s2.

Hypothesis match_final_states:
  forall s1 s2 r1,
  match_states match_values match_errors s1 s2 ->
  final_state L1 s1 r1 ->
  exists r2, final_state L2 s2 r2 /\ match_values r1 r2.

Hypothesis match_error_states:
  forall s1 s2 e1,
  match_states match_values match_errors s1 s2 ->
  error_state L1 s1 e1 ->
  exists e2, error_state L2 s2 e2 /\ match_errors e1 e2.

Section SIMULATION_STAR_WF.
Variable order: state L1 -> state L1 -> Prop.
Hypothesis order_wf: well_founded order.
Hypothesis simulation:
  forall s1 s1', Step L1 s1 s1' ->
  forall s2, match_states match_values match_errors s1 s2 ->
  exists s2',
  (Plus L2 s2 s2' \/ (Star L2 s2 s2' /\ order s1' s1))
  /\ match_states match_values match_errors s1' s2'.

Lemma forward_simulation_star_wf: forward_simulation L1 L2 match_values match_errors.
Proof with eauto.
  apply Forward_simulation with
    (state L1)
    order
    (fun mv me idx s1 s2 => idx = s1 /\ match_states mv me s1 s2)
  . constructor...
  - intros. exploit match_initial_states...
    intros [s2 [A B]]. exists s1, s2...
  - intros * [ ?] ?. edestruct match_final_states...
  - intros * [_ ?] ?. edestruct match_error_states...
  - intros * ? * [-> ?]. exploit simulation...
    intros [s2' [A B]]. exists s1', s2'; intuition auto.
Qed.
End SIMULATION_STAR_WF.

Section SIMULATION_STAR.
Variable measure: state L1 -> nat.
Hypothesis simulation:
  forall s1 s1', Step L1 s1 s1' ->
  forall s2, match_states match_values match_errors s1 s2 ->
  (exists s2', Plus L2 s2 s2' /\ match_states match_values match_errors s1' s2')
  \/ (measure s1' < measure s1 /\ match_states match_values match_errors s1' s2)%nat.

Lemma forward_simulation_star: forward_simulation L1 L2 match_values match_errors.
Proof with eauto.
  apply forward_simulation_star_wf with (ltof _ measure).
  apply well_founded_ltof.
  intros. exploit simulation...
  intros [[s2' [A B]] | [A B]].
  - exists s2'...
  - exists s2; split...
    + right; split... apply star_refl.
Qed.
End SIMULATION_STAR.

Section SIMULATION_PLUS.
Hypothesis simulation:
  forall s1 s1', Step L1 s1 s1' ->
  forall s2, match_states match_values match_errors s1 s2 ->
  exists s2', Plus L2 s2 s2' /\ match_states match_values match_errors s1' s2'.

Lemma forward_simulation_plus: forward_simulation L1 L2 match_values match_errors.
Proof.
  apply forward_simulation_star with (measure := fun _ => O).
  intros. exploit simulation; eauto.
Qed.
End SIMULATION_PLUS.

Section SIMULATION_LOCKSTEP.
Hypothesis simulation:
  forall s1 s1', Step L1 s1 s1' ->
  forall s2, match_states match_values match_errors s1 s2 ->
  exists s2', Step L2 s2 s2' /\ match_states match_values match_errors s1' s2'.

Lemma forward_simulation_lockstep: forward_simulation L1 L2 match_values match_errors.
Proof with eauto.
  apply forward_simulation_plus. intros.
  exploit simulation... intros [s2' [A B]].
  exists s2'; split... apply plus_one...
Qed.
End SIMULATION_LOCKSTEP.

Section SIMULATION_OPT.
Variable measure: state L1 -> nat.
Hypothesis simulation:
  forall s1 s1', Step L1 s1 s1' ->
  forall s2, match_states match_values match_errors s1 s2 ->
  (exists s2', Step L2 s2 s2' /\ match_states match_values match_errors s1' s2')
  \/ (measure s1' < measure s1 /\ match_states match_values match_errors s1' s2)%nat.

Lemma forward_simulation_opt: forward_simulation L1 L2 match_values match_errors.
Proof with eauto.
  apply forward_simulation_star with measure. intros.
  exploit simulation... intros [[s2' [A B]] | [A B]].
  - left; exists s2'; split... apply plus_one...
  - right...
Qed.
End SIMULATION_OPT.

End FORWARD_SIMU_DIAGRAMS.

Section SIMULATION_SEQUENCES.

Context L1 L2 index order match_values match_errors match_states
  (S: fsim_properties L1 L2 index order match_values match_errors match_states).

Lemma simulation_star:
  forall s1 s1', Star L1 s1 s1' ->
  forall i s2, match_states match_values match_errors i s1 s2 ->
  exists i', exists s2', Star L2 s2 s2' /\ match_states match_values match_errors i' s1' s2'.
Proof with eauto.
  induction 1; intros.
  - exists i, s2; split... apply star_refl.
  - exploit fsim_simulation... intros [i' [s2' [A B]]].
    exploit IHstar... intros [i'' [s2'' [C D]]].
    exists i'', s2''; split... eapply star_trans...
    intuition auto. apply plus_star...
Qed.

Lemma simulation_plus:
  forall s1 s1', Plus L1 s1 s1' ->
  forall i s2, match_states match_values match_errors i s1 s2 ->
  (exists i', exists s2', Plus L2 s2 s2' /\ match_states match_values match_errors i' s1' s2')
  \/ (exists i', clos_trans _ order i' i /\ match_states match_values match_errors i' s1' s2).
Proof with eauto.
  induction 1 using plus_ind2; intros.
  - (* base case *)
    exploit fsim_simulation'...
    intros [A | [i' A]].
    + left; auto.
    + right; exists i'; intuition.
  - (* inductive case *)
    exploit fsim_simulation'...
    intros [[i' [s2' [A B]]] | [i' [A B]]].
    + exploit simulation_star;
      [ apply plus_star; eauto
      | eauto
      | ].
      intros [i'' [s2'' [P Q]]].
      left; exists i'', s2''; split...
      eapply plus_star_plus...
    + exploit IHplus...
      intros [[i'' [s2'' [P Q]]] | [i'' [P Q]]].
      * left; exists i'', s2''...
      * right; exists i''; intuition auto.
        eapply t_trans... eapply t_step...
Qed.

Lemma simulation_forever:
  forall i s1 s2,
  Forever L1 s1 -> match_states match_values match_errors i s1 s2 ->
  Forever L2 s2.
Proof with eauto.
  assert (forall i s1 s2,
          Forever L1 s1 -> match_states match_values match_errors i s1 s2 ->
          forever_N (step L2) order (globalenv L2) i s2). {
    cofix COINDHYP; intros.
    inv H. destruct (fsim_simulation S _ _ H1 _ _ H0) as [i' [s2' [A B]]].
    destruct A as [C | [C D]].
    eapply forever_N_plus...
    eapply forever_N_star...
  }
  intros. eapply forever_N_forever...
  eapply fsim_order_wf...
Qed.

End SIMULATION_SEQUENCES.

Record bsim_properties
      (L1 L2: semantics) (index: Type)
      (order: index -> index -> Prop)
      (match_values:  matching_of value L1 L2)
      (match_errors:  matching_of error L1 L2)
      (match_states: (matching_of value L1 L2) ->
                     (matching_of error L1 L2) -> index -> (matching_of state L1 L2))
      : Prop := {
  bsim_order_wf: well_founded order;
  bsim_initial_states_exist:
    forall s1, initial_state L1 s1 -> exists s2, initial_state L2 s2;
  bsim_match_initial_states:
    forall s1 s2, initial_state L1 s1 -> initial_state L2 s2 ->
    exists i s1', initial_state L1 s1' /\ match_states match_values match_errors i s1' s2;
  bsim_match_final_states:
    forall i s1 s2 r2,
    match_states match_values match_errors i s1 s2 ->
    safe L1 s1 -> final_state L2 s2 r2 ->
    exists s1' r1, Star L1 s1 s1' /\ final_state L1 s1' r1 /\ match_values r1 r2;
  bsim_match_error_states:
    forall i s1 s2 e2,
    match_states match_values match_errors i s1 s2 ->
    safe L1 s1 -> error_state L2 s2 e2 ->
    exists s1' e1, Star L1 s1 s1' /\ error_state L1 s1' e1 /\ match_errors e1 e2;
  bsim_progress:
    forall i s1 s2, match_states match_values match_errors i s1 s2 -> safe L1 s1 ->
    (exists res, final_state L2 s2 res) \/
    (exists err, error_state L2 s2 err) \/
    (exists s2', Step L2 s2 s2');
  bsim_simulation:
    forall s2 s2', Step L2 s2 s2' ->
    forall i s1, match_states match_values match_errors i s1 s2 -> safe L1 s1 ->
    exists i' s1',
      (Plus L1 s1 s1' \/ (Star L1 s1 s1' /\ order i' i))
    /\ match_states match_values match_errors i' s1' s2'
}.

Arguments bsim_properties: clear implicits.

Inductive backward_simulation (L1 L2: semantics)
(match_values:  matching_of value L1 L2)
(match_errors:  matching_of error L1 L2) : Prop :=
  Backward_simulation
      (index: Type)
      (order: index -> index -> Prop)
      (match_states: (matching_of value L1 L2) ->
                     (matching_of error L1 L2) -> index -> (matching_of state L1 L2))
      (props: bsim_properties L1 L2 index order match_values match_errors match_states).

Arguments backward_simulation L1 L2 match_values match_errors : clear implicits.
(* Arguments Backward_simulation L1 L2 match_values match_errors index order match_states props. *)

Section FORWARD_TO_BACKWARD.

Context L1 L2 index order match_values match_errors match_states
  (FS: fsim_properties L1 L2 index order match_values match_errors match_states).
Hypothesis L2_determinate: determinate L2.

(* this relation seems to be talking about the excess/admin steps
   needed to reach a state that matches the beginning of a simulated
   sequence in the target *)

(* [TOL] This might be talking about progress, and is saying
   (in the final and error cases) that we can't really make
    progress, so it's sort of progress as good as you can get.

     *)
Inductive f2b_transitions: state L1 -> state L2 -> Prop :=
  | f2b_trans_final: forall s1 s2 s1' r1 r2,
      Star L1 s1 s1' ->
      match_values r1 r2 ->
      final_state L1 s1' r1 ->
      final_state L2 s2  r2 ->
      f2b_transitions s1 s2
  | f2b_trans_error: forall s1 s2 s1' e1 e2,
      Star L1 s1 s1' ->
      match_errors e1 e2 ->
      error_state L1 s1' e1 ->
      error_state L2 s2  e2 ->
      f2b_transitions s1 s2
  | f2b_trans_step: forall s1 s2 s1' s1'' s2' i' i'',
      Star L1 s1 s1' ->
      Step L1 s1' s1'' ->
      Plus L2 s2 s2' ->
      match_states match_values match_errors i'  s1'  s2  ->
      match_states match_values match_errors i'' s1'' s2' ->
      f2b_transitions s1 s2.

Lemma f2b_progress: forall i s1 s2,
  match_states match_values match_errors i s1 s2 -> safe L1 s1 ->
  f2b_transitions s1 s2.
Proof with eauto.
  intros i0; pattern i0.
  apply well_founded_ind with (R := order).
  - eapply fsim_order_wf...
  - intros i REC s1 s2 MATCH SAFE.
    destruct (SAFE s1) as [[res FINAL] | [[err ERROR] | [s1' STEP1]]].
    + apply star_refl.
    + (* final state reached *)
      edestruct fsim_match_final_states as [r2 [FIN2 MV]];
      [exact FS|exact MATCH|exact FINAL|].
      eapply f2b_trans_final;
      [ apply star_refl | | |]...
    + (* error state reached *)
      edestruct fsim_match_error_states as [r2 [FIN2 MV]];
      [exact FS|exact MATCH|exact ERROR|].
      eapply f2b_trans_error;
      [ apply star_refl | | |]...
    + (* L1 can make one step *)
      exploit (fsim_simulation FS)... intros [i' [s2' [A MATCH']]].
      assert (B: Plus L2 s2 s2' \/ (s2' = s2 /\ order i' i)). {
        intuition auto. destruct (star_inv H0); intuition auto. }
      clear A. destruct B as [PLUS2 | [EQ1 ORDER]].
      * eapply f2b_trans_step... apply star_refl.
      * subst. exploit REC...
        --eapply star_safe... apply star_one...
        --intros TRANS; inv TRANS.
          ++eapply f2b_trans_final... eapply one_star_star...
          ++eapply f2b_trans_error... eapply one_star_star...
          ++eapply f2b_trans_step...  eapply one_star_star...
Qed.

Lemma f2b_determinacy_inv:
  forall s2 s2' s2'',
  Step L2 s2 s2' -> Step L2 s2 s2'' ->
  s2' = s2''.
Proof with eauto.
  intros. eapply sd_determ...
Qed.

(* (* only makes sense for traces *)
Lemma f2b_determinacy_star:
  forall s s1, Star L2 s s1 ->
  forall s2 s3,
  Step L2 s1 s2 ->
  Star L2 s s3 ->
  Star L2 s1 s3.
Proof with eauto.
  intros s0 s01 ST0. pattern s0, s01.
  eapply star_ind...
  intros. inv H3.
  - admit.
  - erewrite <- (f2b_determinacy_inv _ _ _ H H4) in *...
Admitted. *)

Inductive f2b_index : Type :=
  | F2BI_before (n: nat)
  | F2BI_after (n: nat).

Inductive f2b_order: f2b_index -> f2b_index -> Prop :=
  | f2b_order_before: forall n n',
      (n' < n)%nat ->
      f2b_order (F2BI_before n') (F2BI_before n)
  | f2b_order_after: forall n n',
      (n' < n)%nat ->
      f2b_order (F2BI_after n') (F2BI_after n)
  | f2b_order_switch: forall n n',
      f2b_order (F2BI_before n') (F2BI_after n).

Lemma wf_f2b_order:
  well_founded f2b_order.
Proof with auto.
  assert (ACC1: forall n, Acc f2b_order (F2BI_before n)). {
    intros n; pattern n; apply lt_wf_ind; intros.
    constructor; intros. inv H0... }
  assert (ACC2: forall n, Acc f2b_order (F2BI_after n)). {
    intros n; pattern n; apply lt_wf_ind; intros.
    constructor; intros. inv H0... }
  intros []...
Qed.

Inductive f2b_match_states: f2b_index -> state L1 -> state L2 -> Prop :=
  | f2b_match_at: forall i s1 s2,
      match_states match_values match_errors i s1 s2 ->
      f2b_match_states (F2BI_after O) s1 s2 (*
  | f2b_match_before: forall s1 s1' s2b s2 n s2a i,
      Step L1 s1 s1' ->
      Star L2 s2b s2 ->
      starN (step L2) (globalenv L2) n s2 s2a ->
      match_states i s1 s2b ->
      match_states i s1' s2a ->
      f2b_match_states (F2BI_before n) s1 s2 *)
  | f2b_match_after: forall n s2 s2a s1 i,
      starN (step L2) (globalenv L2) (S n) s2 s2a ->
      match_states match_values match_errors i s1 s2a ->
      f2b_match_states (F2BI_after (S n)) s1 s2.

Remark f2b_match_after':
  forall n s2 s2a s1 i,
  starN (step L2) (globalenv L2) n s2 s2a ->
  match_states match_values match_errors i s1 s2a ->
  f2b_match_states (F2BI_after n) s1 s2.
Proof with eauto.
  intros. inv H.
  - econstructor...
  - econstructor... econstructor...
Qed.

Lemma f2b_simulation_step:
  forall s2 s2', Step L2 s2 s2' ->
  forall i s1, f2b_match_states i s1 s2 -> safe L1 s1 ->
  exists i' s1',
    (Plus L1 s1 s1' \/ (Star L1 s1 s1' /\ f2b_order i' i))
     /\ f2b_match_states i' s1' s2'.
Proof with eauto.
  intros s2 s2' STEP2 i s1 MATCH SAFE. inv MATCH.
  - exploit f2b_progress... intros TRANS; inv TRANS.
    + (* 1.1 L1 can reach final state and
         L2 is at final state: impossible! *)
      exploit (sd_final_nostep L2_determinate)...
      contradiction.
    + exploit (sd_error_nostep L2_determinate)...
      contradiction.
    + (* 1.2 L1 can make 0 or more steps; L2
         can make 1 or more matching steps *)
      inv H2. exploit f2b_determinacy_inv;
      [ eexact H5
      | eexact STEP2
      | intros <-].
      destruct (star_starN H6) as [n STEPS2].
      exists (F2BI_after n); exists s1''; split.
      left.
      * eapply star_one_plus...
      * eapply f2b_match_after'...
  - inv H. exploit f2b_determinacy_inv;
    [ eexact H2
    | eexact STEP2| intros <-].
    exists (F2BI_after n), s1; split.
    + right; split.
      * apply star_refl.
      * repeat constructor.
    + eapply f2b_match_after'...
Qed.

End FORWARD_TO_BACKWARD.

Lemma forward_to_backward_simulation:
  forall L1 L2 match_values match_errors,
  forward_simulation L1 L2 match_values match_errors -> determinate L2 ->
  backward_simulation L1 L2 match_values match_errors.
Proof with eauto.
  intros L1 L2 mv me [index order ms FS] L2D.
  eapply Backward_simulation with
    (order := f2b_order)
    (match_states := fun mv' me' => (@f2b_match_states L1 L2 index mv' me' ms)).
  constructor.
  - (* well founded *)
    apply wf_f2b_order.
  - (* initial states exist *)
    intros. exploit (fsim_match_initial_states FS)...
    intros [i [s2 [A B]]]. exists s2...
  - (* initial states *)
    intros. exploit (fsim_match_initial_states FS)...
    intros [i [s2' [A B]]]. replace s2' with s2 in *
      by (eapply sd_initial_determ; eauto).
    exists (F2BI_after O), s1. split...
    econstructor...
  - (* final states *)
    intros. inv H.
    + exploit f2b_progress... intros TRANS; inv TRANS.
      * erewrite (sd_final_determ L2D _ _ _ H1 H5)...
      * exfalso; eapply fin_err_disjoint...
      * exfalso. inv H4.
        eapply (sd_final_nostep L2D _ _ H1)...
    + exfalso. inv H2.
      eapply (sd_final_nostep L2D _ _ H1)...
  - (* error states *)
    intros. inv H.
    + exploit f2b_progress... intros TRANS; inv TRANS.
      * exfalso; eapply fin_err_disjoint...
      * erewrite (sd_error_determ L2D _ _ _ H1 H5)...
      * exfalso. inv H4.
        eapply (sd_error_nostep L2D)...
    + exfalso. inv H2.
      eapply (sd_error_nostep L2D)...
  - (* progress *)
    intros. inv H.
    + exploit f2b_progress... intro TRANS; inv TRANS;
      [ left; exists r2
      | right; left
      | right; inv H3]...
    + inv H1...
  - (* simulation *)
    eapply f2b_simulation_step...
Qed.

(* Close Scope smallstep_scope. *)