(** * Equiv: Program Equivalence *)

Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From Coq Require Import Bool.Bool.
From Coq Require Import Arith.Arith.
From Coq Require Import Init.Nat.
From Coq Require Import Arith.PeanoNat. Import Nat.
From Coq Require Import Arith.EqNat.
From Coq Require Import Lia.
From Coq Require Import Lists.List. Import ListNotations.
From Coq Require Import Logic.FunctionalExtensionality.
From PLF Require Export Imp.
From PLF Require Import Maps.

(** *** Before you Get Started:

    - Create a fresh directory for this volume. (Do not try to mix the
      files from this volume with files from _Logical Foundations_ in
      the same directory: the result will not make you happy.)

    - The new directory should contain at least the following files:
         - [Imp.v] (make sure it is the one from the PLF distribution,
           not the one from LF: they are slightly different);
         - [Maps.v] (ditto)
         - [Equiv.v] (this file)
         - [_CoqProject], containing the following line:

           -Q . PLF

    - Reminder: If you see errors like this...

             Compiled library PLF.Maps (in file
             /Users/.../plf/Maps.vo) makes inconsistent assumptions
             over library Coq.Init.Logic

      ... it may mean something went wrong with the above steps.
      Doing "[make clean]" (or manually removing everything except
      [.v] and [_CoqProject] files) may help. *)

(** *** Advice for Working on Exercises:

    - Most of the Coq proofs we ask you to do are similar to proofs
      that we've provided.  Before starting to work on exercises
      problems, take the time to work through our proofs (both
      informally 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 by random
      experimentation or following your nose.  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.  Alternately, grab a friend and try to
      convince them that the theorem is true; then try to formalize
      your explanation.

    - Use automation to save work!  The proofs in this chapter can get
      pretty long if you try to write out all the cases explicitly. *)

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

(** In an earlier 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
    in that setting 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 for the
    full Imp language, in particular assignment, we need to consider
    the role of variables and state. *)

(* ================================================================= *)
(** ** Definitions *)

(** For [aexp]s and [bexp]s with variables, the definition we want is
    clear: 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.

(** Here are some simple examples of equivalences of arithmetic
    and boolean expressions. *)

Theorem aequiv_example: aequiv <{ X - X }> <{ 0 }>.
Proof.
  intros st. simpl. lia.
Qed.

Theorem bequiv_example: bequiv <{ X - X = 0 }> <{ true }>.
Proof.
  intros st. unfold beval.
  rewrite aequiv_example. reflexivity.
Qed.

(** 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 started in the
    same initial state," because some commands, when run 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 (1) both diverge
    or (2) 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),
    (st =[ c1 ]=> st') <-> (st =[ c2 ]=> st').

(* ================================================================= *)
(** ** Simple Examples *)

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

Theorem skip_left : forall c,
  cequiv
    <{ skip; c }>
    c.
Proof.
  (* WORKED IN CLASS *)
  intros c st st'.
  split; intros H.
  - (* -> *)
    inversion H. subst.
    inversion H2. subst.
    assumption.
  - (* <- *)
    apply E_Seq with st.
    apply E_Skip.
    assumption.
Qed.

(** **** Exercise: 2 stars, standard (skip_right)

    Prove that adding a [skip] after a command results in an
    equivalent program *)

Theorem skip_right : forall c,
  cequiv
    <{ c ; skip }>
    c.
Proof.
  intros c st st'.
  split; intro H.
  -
    inversion H. subst.
    inversion H5. subst.
    assumption.
  -
    apply E_Seq with st'.
    assumption.
    apply E_Skip.
Qed.
(** [] *)

(** Similarly, here is a simple transformation that optimizes [if]
    commands: *)

Theorem if_true_simple : forall c1 c2,
  cequiv
    <{ if true then c1 else c2 end }>
    c1.
Proof.
  intros c1 c2.
  split; intros H.
  - (* -> *)
    inversion H; subst. assumption. discriminate.
  - (* <- *)
    apply E_IfTrue. reflexivity. assumption.
Qed.

(** Of course, no (human) programmer would write a conditional whose
    guard is literally [true].  But they might write one whose guard
    is _equivalent_ to true:

    _Theorem_: If [b] is equivalent to [true], then [if b then c1
    else c2 end] is equivalent to [c1].
   _Proof_:

     - ([->]) We must show, for all [st] and [st'], that if [st =[
       if b then c1 else c2 end ]=> st'] then [st =[ c1 ]=> st'].

       Proceed by cases on the rules that could possibly have been
       used to show [st =[ if b then c1 else c2 end ]=> st'], namely
       [E_IfTrue] and [E_IfFalse].

       - Suppose the final rule in the derivation of [st =[ if b
         then c1 else c2 end ]=> st'] was [E_IfTrue].  We then have,
         by the premises of [E_IfTrue], that [st =[ c1 ]=> st'].
         This is exactly what we set out to prove.

       - On the other hand, suppose the final rule in the derivation
         of [st =[ if b then c1 else c2 end ]=> st'] was [E_IfFalse].
         We then know that [beval st b = false] and [st =[ c2 ]=> st'].

         Recall that [b] is equivalent to [true], i.e., forall [st],
         [beval st b = beval st <{true}> ].  In particular, this means
         that [beval st b = true], since [beval st <{true}> = 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
       [st =[ c1 ]=> st'] then
       [st =[ if b then c1 else c2 end ]=> st'].

       Since [b] is equivalent to [true], we know that [beval st b] =
       [beval st <{true}> ] = [true].  Together with the assumption that
       [st =[ c1 ]=> st'], we can apply [E_IfTrue] to derive
       [st =[ if b then c1 else c2 end ]=> st'].  []

   Here is the formal version of this proof: *)

Theorem if_true: forall b c1 c2,
  bequiv b <{true}>  ->
  cequiv
    <{ if b then c1 else c2 end }>
    c1.
Proof.
  intros b c1 c2 Hb.
  split; intros H.
  - (* -> *)
    inversion H. subst.
    + (* b evaluates to true *)
      assumption.
    + (* b evaluates to false (contradiction) *)
      unfold bequiv in Hb. simpl in Hb.
      rewrite Hb in H5.
      discriminate.
  - (* <- *)
    apply E_IfTrue; try assumption.
    unfold bequiv in Hb. simpl in Hb.
    apply Hb. Qed.

(** **** Exercise: 2 stars, standard, especially useful (if_false) *)
Theorem if_false : forall b c1 c2,
  bequiv b <{false}> ->
  cequiv
    <{ if b then c1 else c2 end }>
    c2.
Proof.
  intros b c1 c2 Hb.
  split. intro.
  -
    inversion H. unfold bequiv in Hb. rewrite Hb in H5. discriminate.
    subst. assumption.
  -
    apply E_IfFalse; try assumption.
    unfold bequiv in Hb. simpl in Hb.
    apply Hb.
Qed.
(** [] *)

(** **** Exercise: 3 stars, standard (swap_if_branches)
    Show that we can swap the branches of an [if] if we also negate its
    guard. *)

Theorem swap_if_branches : forall b c1 c2,
  cequiv
    <{ if b then c1 else c2 end }>
    <{ if ~ b then c2 else c1 end }>.
Proof.
  intros.
  unfold cequiv.
  split; intros; inversion H; subst.
  -
    assert (beval st (BNot b) = false).
    { simpl. rewrite H5. auto. }
    apply E_IfFalse; assumption.
  -
    assert (beval st (BNot b) = true).
    { simpl. rewrite H5. auto.}
    apply E_IfTrue; assumption.
  -
    assert (beval st b = false).
    { simpl in H5. apply negb_true_iff in H5. assumption.}
    apply E_IfFalse; assumption.
  -
    assert (beval st b = true).
    { simpl in H5. apply negb_false_iff in H5. auto.}
    apply E_IfTrue; assumption.
Qed.
(** [] *)

(** For [while] loops, we can give a similar pair of theorems.  A loop
    whose guard is equivalent to [false] is equivalent to [skip],
    while a loop whose guard is equivalent to [true] is equivalent to
    [while true do skip end] (or any other non-terminating program).
    The first of these facts is easy. *)

Theorem while_false : forall b c,
  bequiv b <{false}> ->
  cequiv
    <{ while b do c end }>
    <{ skip }>.
Proof.
  intros b c Hb. split; intros H.
  - (* -> *)
    inversion H. subst.
    + (* E_WhileFalse *)
      apply E_Skip.
    + (* E_WhileTrue *)
      rewrite Hb in H2. discriminate.
  - (* <- *)
    inversion H. subst.
    apply E_WhileFalse.
    apply Hb.
Qed.

(** **** Exercise: 2 stars, advanced, optional (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 [true] never
    terminate. *)

(** _Lemma_: If [b] is equivalent to [true], then it cannot be
    the case that [st =[ while b do c end ]=> st'].

    _Proof_: Suppose that [st =[ while b do c end ]=> st'].  We show,
    by induction on a derivation of [st =[ while b do c end ]=> st'],
    that this assumption leads to a contradiction. The only two cases
    to consider are [E_WhileFalse] and [E_WhileTrue], the others
    are contradictory.

    - Suppose [st =[ while b do c end ]=> st'] is proved using rule
      [E_WhileFalse].  Then by assumption [beval st b = false].  But
      this contradicts the assumption that [b] is equivalent to
      [true].

    - Suppose [st =[ while b do c end ]=> st'] is proved using rule
      [E_WhileTrue].  We must have that:

      1. [beval st b = true],
      2. there is some [st0] such that [st =[ c ]=> st0] and
         [st0 =[ while b do c end ]=> st'],
      3. and we are given the induction hypothesis that
         [st0 =[ while b do c end ]=> st'] leads to a contradiction,

      We obtain a contradiction by 2 and 3. [] *)

Lemma while_true_nonterm : forall b c st st',
  bequiv b <{true}> ->
  ~( st =[ while b do c end ]=> st' ).
Proof.
  (* WORKED IN CLASS *)
  intros b c st st' Hb.
  intros H.
  remember <{ while b do c end }> as cw eqn:Heqcw.
  induction H;
  (* Most rules don't apply; we rule them out by inversion: *)
  inversion Heqcw; subst; clear Heqcw.
  (* The two interesting cases are the ones for while loops: *)
  - (* E_WhileFalse *) (* contradictory -- b is always true! *)
    unfold bequiv in Hb.
    (* [rewrite] is able to instantiate the quantifier in [st] *)
    rewrite Hb in H. discriminate.
  - (* E_WhileTrue *) (* immediate from the IH *)
    apply IHceval2. reflexivity.  Qed.

(** **** Exercise: 2 stars, standard, optional (while_true_nonterm_informal)

    Explain what the lemma [while_true_nonterm] means in English.

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

(** **** Exercise: 2 stars, standard, especially useful (while_true)

    Prove the following theorem. _Hint_: You'll want to use
    [while_true_nonterm] here. *)

Theorem while_true : forall b c,
  bequiv b <{true}>  ->
  cequiv
    <{ while b do c end }>
    <{ while true do skip end }>.
Proof.
  intros.
  unfold cequiv. split; intro.
  - apply while_true_nonterm in H0. inversion H0. assumption.
  - apply while_true_nonterm in H0. inversion H0. unfold bequiv. simpl. intro. reflexivity.
Qed.
(** [] *)

(** A more interesting fact about [while] commands is that any number
    of copies of the body can be "unrolled" without changing meaning.

    Loop unrolling is an important transformation in real compilers! *)

Theorem loop_unrolling : forall b c,
  cequiv
    <{ while b do c end }>
    <{ if b then c ; while b do c end else skip end }>.
Proof.
  (* WORKED IN CLASS *)
  intros b c st st'.
  split; intros Hce.
  - (* -> *)
    inversion Hce; subst.
    + (* loop doesn't run *)
      apply E_IfFalse. assumption. apply E_Skip.
    + (* loop runs *)
      apply E_IfTrue. assumption.
      apply E_Seq with (st' := st'0). assumption. assumption.
  - (* <- *)
    inversion Hce; subst.
    + (* loop runs *)
      inversion H5; subst.
      apply E_WhileTrue with (st' := st'0).
      assumption. assumption. assumption.
    + (* loop doesn't run *)
      inversion H5; subst. apply E_WhileFalse. assumption.  Qed.

(** **** Exercise: 2 stars, standard, optional (seq_assoc) *)
Theorem seq_assoc : forall c1 c2 c3,
  cequiv <{(c1;c2);c3}> <{c1;(c2;c3)}>.
Proof.
  intros. unfold cequiv. split; intros.
  -
    inversion H. inversion H2. subst.
    apply E_Seq with (st':=st'1).
    assumption. apply E_Seq with (st':=st'0);
    assumption.
  -
    inversion H. inversion H5. subst.
    apply E_Seq with (st':=st'1). apply E_Seq with (st':=st'0);
    assumption. assumption.
Qed.
(** [] *)

(** Proving program properties involving assignments is one place
    where the fact that program states are treated
    extensionally (e.g., [x !-> m x ; m] and [m] are equal maps) comes
    in handy. *)

Theorem identity_assignment : forall x,
  cequiv
    <{ x := x }>
    <{ skip }>.
Proof.
  intros.
  split; intro H; inversion H; subst; clear H.
  - (* -> *)
    rewrite t_update_same.
    apply E_Skip.
  - (* <- *)
    assert (Hx : st' =[ x := x ]=> (x !-> st' x ; st')).
    { apply E_Asgn. reflexivity. }
    rewrite t_update_same in Hx.
    apply Hx.
Qed.

(** **** Exercise: 2 stars, standard, especially useful (assign_aequiv) *)
Theorem assign_aequiv : forall (x : string) a,
  aequiv x a ->
  cequiv <{ skip }> <{ x := a }>.
Proof.
  intros.
  unfold cequiv. intros. split; intros.
  - inversion H0. subst. assert ((x !-> (aeval st' a); st') = st').
    { unfold aequiv in H.  rewrite <- H. apply t_update_same. }
    rewrite <- H1 at 2. apply E_Asgn. reflexivity.
  - inversion H0. subst. assert ((x !-> (aeval st a); st) = st).
    { unfold aequiv in H.  rewrite <- H. apply t_update_same. }
    rewrite H1. apply E_Skip.
Qed.
(** [] *)

(** **** Exercise: 2 stars, standard (equiv_classes) *)

(** Given the following programs, group together those that are
    equivalent in Imp. Your answer should be given as a list of lists,
    where each sub-list represents a group of equivalent programs. For
    example, if you think programs (a) through (h) are all equivalent
    to each other, but not to (i), your answer should look like this:

       [ [prog_a;prog_b;prog_c;prog_d;prog_e;prog_f;prog_g;prog_h] ;
         [prog_i] ]

    Write down your answer below in the definition of
    [equiv_classes]. *)

Definition prog_a : com :=
  <{ while ~(X <= 0) do
       X := X + 1
     end }>.

Definition prog_b : com :=
  <{ if (X = 0) then
       X := X + 1;
       Y := 1
     else
       Y := 0
     end;
     X := X - Y;
     Y := 0 }>.

Definition prog_c : com :=
  <{ skip }> .

Definition prog_d : com :=
  <{ while ~(X = 0) do
       X := (X * Y) + 1
     end }>.

Definition prog_e : com :=
  <{ Y := 0 }>.

Definition prog_f : com :=
  <{ Y := X + 1;
     while ~(X = Y) do
       Y := X + 1
     end }>.

Definition prog_g : com :=
  <{ while true do
       skip
     end }>.

Definition prog_h : com :=
  <{ while ~(X = X) do
       X := X + 1
     end }>.

Definition prog_i : com :=
  <{ while ~(X = Y) do
       X := Y + 1
     end }>.

Definition equiv_classes : list (list com) :=
  [[prog_a; prog_d]; [prog_b; prog_e]; [prog_c; prog_f; prog_h]; [prog_g]; [prog_i]].

(* Do not modify the following line: *)
Definition manual_grade_for_equiv_classes : option (nat*string) := None.
(** [] *)

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

(** We next consider some fundamental properties of program
    equivalence. *)

(* ================================================================= *)
(** ** 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.  The proofs are all easy. *)

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'. reflexivity.  Qed.

Lemma sym_cequiv : forall (c1 c2 : com),
  cequiv c1 c2 -> cequiv c2 c1.
Proof.
  unfold cequiv. intros c1 c2 H st st'.
  rewrite H. reflexivity.
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'.
  rewrite 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 larger programs in which they are embedded:

                 aequiv a a'
         -------------------------
         cequiv (x := a) (x := a')

              cequiv c1 c1'
              cequiv c2 c2'
         --------------------------
         cequiv (c1;c2) (c1';c2')

    ... and so on for the other forms of commands. *)

(** (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 CAsgn_congruence : forall x a a',
  aequiv a a' ->
  cequiv <{x := a}> <{x := a'}>.
Proof.
  intros x a a' Heqv st st'.
  split; intros Hceval.
  - (* -> *)
    inversion Hceval. subst. apply E_Asgn.
    rewrite Heqv. reflexivity.
  - (* <- *)
    inversion Hceval. subst. apply E_Asgn.
    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
    [b] is equivalent to [b'] and [c] is equivalent to [c'], then
    [while b do c end] is equivalent to [while b' do c' end].

    _Proof_: Suppose [b] is equivalent to [b'] and [c] is
    equivalent to [c'].  We must show, for every [st] and [st'], that
    [st =[ while b do c end ]=> st'] iff [st =[ while b' do c'
    end ]=> st'].  We consider the two directions separately.

      - ([->]) We show that [st =[ while b do c end ]=> st'] implies
        [st =[ while b' do c' end ]=> st'], by induction on a
        derivation of [st =[ while b do c end ]=> st'].  The only
        nontrivial cases are when the final rule in the derivation is
        [E_WhileFalse] or [E_WhileTrue].

          - [E_WhileFalse]: In this case, the form of the rule gives us
            [beval st b = false] and [st = st'].  But then, since
            [b] and [b'] are equivalent, we have [beval st b' =
            false], and [E_WhileFalse] applies, giving us
            [st =[ while b' do c' end ]=> st'], as required.

          - [E_WhileTrue]: The form of the rule now gives us [beval st
            b = true], with [st =[ c ]=> st'0] and [st'0 =[ while
            b do c end ]=> st'] for some state [st'0], with the
            induction hypothesis [st'0 =[ while b' do c' end ]=>
            st'].

            Since [c] and [c'] are equivalent, we know that [st =[
            c' ]=> st'0].  And since [b] and [b'] are equivalent,
            we have [beval st b' = true].  Now [E_WhileTrue] applies,
            giving us [st =[ while b' do c' end ]=> st'], as
            required.

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

Theorem CWhile_congruence : forall b b' c c',
  bequiv b b' -> cequiv c c' ->
  cequiv <{ while b do c end }> <{ while b' do c' end }>.
Proof.
  (* WORKED IN CLASS *)

  (* We will prove one direction in an "assert"
     in order to reuse it for the converse. *)
  assert (A: forall (b b' : bexp) (c c' : com) (st st' : state),
             bequiv b b' -> cequiv c c' ->
             st =[ while b do c end ]=> st' ->
             st =[ while b' do c' end ]=> st').
  { unfold bequiv,cequiv.
    intros b b' c c' st st' Hbe Hc1e Hce.
    remember <{ while b do c end }> as cwhile
      eqn:Heqcwhile.
    induction Hce; inversion Heqcwhile; subst.
    + (* E_WhileFalse *)
      apply E_WhileFalse. rewrite <- Hbe. apply H.
    + (* E_WhileTrue *)
      apply E_WhileTrue with (st' := st').
      * (* show loop runs *) rewrite <- Hbe. apply H.
      * (* body execution *)
        apply (Hc1e st st').  apply Hce1.
      * (* subsequent loop execution *)
        apply IHHce2. reflexivity. }

  intros. split.
  - apply A; assumption.
  - apply A.
    + apply sym_bequiv. assumption.
    + apply sym_cequiv. assumption.
Qed.

(** **** Exercise: 3 stars, standard, optional (CSeq_congruence) *)
Theorem CSeq_congruence : forall c1 c1' c2 c2',
  cequiv c1 c1' -> cequiv c2 c2' ->
  cequiv <{ c1;c2 }> <{ c1';c2' }>.
Proof.
  assert (A: forall  (c1 c1' c2 c2' : com) (st st' : state),
             cequiv c1 c1' -> cequiv c2 c2' ->
             st =[ c1;c2 ]=> st' ->
             st =[ c1';c2' ]=> st').
  {
    unfold cequiv.
    intros c1 c1' c2 c2' st st' Hc1e Hc2e Hce.
    induction c1; inversion Hce; subst; apply E_Seq with (st':=st'0);
      apply Hc1e || apply Hc2e; assumption.
  }
  intros. split.
  - apply A; assumption.
  - apply A; apply sym_cequiv; assumption.
Qed.

(** [] *)

(** **** Exercise: 3 stars, standard (CIf_congruence) *)
Theorem CIf_congruence : forall b b' c1 c1' c2 c2',
  bequiv b b' -> cequiv c1 c1' -> cequiv c2 c2' ->
  cequiv <{ if b then c1 else c2 end }>
         <{ if b' then c1' else c2' end }>.
Proof.
  assert (A: forall b b' c1 c1' c2 c2' st st',
             bequiv b b' -> cequiv c1 c1' ->
             cequiv c2 c2' ->
             st =[ if b then c1 else c2 end ]=> st' ->  st =[ if b' then c1' else c2' end ]=> st' ).
  {
    unfold bequiv, cequiv.
    intros b b' c1 c1' c2 c2' st st' Hbe Hc1e Hc2e Hce.
    remember <{ if b then c1 else c2 end}> as cif eqn:Heqcif.
    induction Hce; inversion Heqcif; subst.
    - apply E_IfTrue. rewrite <- Hbe. assumption. apply Hc1e. assumption.
    - apply E_IfFalse. rewrite <- Hbe. assumption. apply Hc2e. assumption.
  }
  intros. split.
  - apply A; assumption.
  - apply A; apply sym_bequiv || apply sym_cequiv; assumption.
Qed.
(** [] *)

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

Example congruence_example:
  cequiv
    (* Program 1: *)
    <{ X := 0;
       if (X = 0)
       then
         Y := 0
       else
         Y := 42
       end }>
    (* Program 2: *)
    <{ X := 0;
       if (X = 0)
       then
         Y := X - X   (* <--- Changed here *)
       else
         Y := 42
       end }>.
Proof.
  apply CSeq_congruence.
  - apply refl_cequiv.
  - apply CIf_congruence.
    + apply refl_bequiv.
    + apply CAsgn_congruence. unfold aequiv. simpl.
      symmetry. apply minus_diag.
    + apply refl_cequiv.
Qed.

(** **** Exercise: 3 stars, advanced, optional (not_congr)

    We've shown that the [cequiv] relation is both an equivalence and
    a congruence on commands.  Can you think of a relation on commands
    that is an equivalence but _not_ a congruence? *)

(* Consider the boolean property (P com) := "Have depth not more than 2"
    define the relation : com1 ~ com2 <-> P com1 = P com2
    [] *)

(* ################################################################# *)
(** * Program Transformations *)

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

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

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 x        => AId x
  | <{ a1 + a2 }>  =>
    match (fold_constants_aexp a1,
           fold_constants_aexp a2)
    with
    | (ANum n1, ANum n2) => ANum (n1 + n2)
    | (a1', a2') => <{ a1' + a2' }>
    end
  | <{ a1 - a2 }> =>
    match (fold_constants_aexp a1,
           fold_constants_aexp a2)
    with
    | (ANum n1, ANum n2) => ANum (n1 - n2)
    | (a1', a2') => <{ a1' - a2' }>
    end
  | <{ a1 * a2 }>  =>
    match (fold_constants_aexp a1,
           fold_constants_aexp a2)
    with
    | (ANum n1, ANum n2) => ANum (n1 * n2)
    | (a1', a2') => <{ a1' * a2' }>
    end
  end.

Example fold_aexp_ex1 :
    fold_constants_aexp <{ (1 + 2) * X }>
  = <{ 3 * 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 <{ X - ((0 * 6) + Y) }> = <{ X - (0 + Y) }>.
Proof. reflexivity. Qed.

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

Fixpoint fold_constants_bexp (b : bexp) : bexp :=
  match b with
  | <{true}>        => <{true}>
  | <{false}>       => <{false}>
  | <{ a1 = a2 }>  =>
      match (fold_constants_aexp a1,
             fold_constants_aexp a2) with
      | (ANum n1, ANum n2) =>
          if n1 =? n2 then <{true}> else <{false}>
      | (a1', a2') =>
          <{ a1' = a2' }>
      end
  | <{ a1 <= a2 }>  =>
      match (fold_constants_aexp a1,
             fold_constants_aexp a2) with
      | (ANum n1, ANum n2) =>
          if n1 <=? n2 then <{true}> else <{false}>
      | (a1', a2') =>
          <{ a1' <= a2' }>
      end
  | <{ ~ b1 }>  =>
      match (fold_constants_bexp b1) with
      | <{true}> => <{false}>
      | <{false}> => <{true}>
      | b1' => <{ ~ b1' }>
      end
  | <{ b1 && b2 }>  =>
      match (fold_constants_bexp b1,
             fold_constants_bexp b2) with
      | (<{true}>, <{true}>) => <{true}>
      | (<{true}>, <{false}>) => <{false}>
      | (<{false}>, <{true}>) => <{false}>
      | (<{false}>, <{false}>) => <{false}>
      | (b1', b2') => <{ b1' && b2' }>
      end
  end.

Example fold_bexp_ex1 :
  fold_constants_bexp <{ true && ~(false && true) }>
  = <{ true }>.
Proof. reflexivity. Qed.

Example fold_bexp_ex2 :
  fold_constants_bexp <{ (X = Y) && (0 = (2 - (1 + 1))) }>
  = <{ (X = Y) && true }>.
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 }>
  | <{ x := a }> =>
      <{ x := (fold_constants_aexp a) }>
  | <{ c1 ; c2 }>  =>
      <{ fold_constants_com c1 ; fold_constants_com c2 }>
  | <{ if b then c1 else c2 end }> =>
      match fold_constants_bexp b with
      | <{true}>  => fold_constants_com c1
      | <{false}> => fold_constants_com c2
      | b' => <{ if b' then fold_constants_com c1
                       else fold_constants_com c2 end}>
      end
  | <{ while b do c1 end }> =>
      match fold_constants_bexp b with
      | <{true}> => <{ while true do skip end }>
      | <{false}> => <{ skip }>
      | b' => <{ while b' do (fold_constants_com c1) end }>
      end
  end.

Example fold_com_ex1 :
  fold_constants_com
    (* Original program: *)
    <{ X := 4 + 5;
       Y := X - 3;
       if ((X - Y) = (2 + 4)) then skip
       else Y := 0 end;
       if (0 <= (4 - (2 + 1))) then Y := 0
       else skip end;
       while (Y = 0) do
         X := X + 1
       end }>
  = (* After constant folding: *)
    <{ X := 9;
       Y := X - 3;
       if ((X - Y) = 6) then skip
       else Y := 0 end;
       Y := 0;
       while (Y = 0) do
         X := X + 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.
  induction a; simpl;
    (* ANum and AId follow immediately *)
    try reflexivity;
    (* APlus, AMinus, and AMult follow from the IH
       and the observation that
              aeval st (<{ 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, standard, optional (fold_bexp_Eq_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 b],
   for all boolean expressions [b].  Proceed by induction on [b].  We
   show just the case where [b] has the form [a1 = a2].

   In this case, we must show

       beval st <{ a1 = a2 }>
     = beval st (fold_constants_bexp <{ 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 <{ a1 = a2 }>
         = if n1 =? n2 then <{true}> else <{false}>

       and

           beval st <{a1 = a2}>
         = (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 <{a1 = a2}>
         = (aeval a1) =? (aeval a2)
         = n1 =? n2.

       Also, it is easy to see (by considering the cases [n1 = n2] and
       [n1 <> n2] separately) that

           beval st (if n1 =? n2 then <{true}> else <{false}>)
         = if n1 =? n2 then beval st <{true}> else beval st <{false}>
         = if n1 =? n2 then true else false
         = n1 =? n2.

       So

           beval st (<{ a1 = a2 }>)
         = n1 =? n2.
         = beval st (if n1 =? n2 then <{true}> else <{false}>),

       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 <{a1 = a2}>
         = beval st (<{ (fold_constants_aexp a1) =
                         (fold_constants_aexp a2) }>),

       which, by the definition of [beval], is the same as showing

           (aeval st a1) =? (aeval st a2)
         = (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.
  induction b;
    (* true and false are immediate *)
    try reflexivity.
  - (* BEq *)
    simpl.
    remember (fold_constants_aexp a1) as a1' eqn:Heqa1'.
    remember (fold_constants_aexp a2) as a2' eqn:Heqa2'.
    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 (n =? n0); reflexivity.
  - (* BLe *)
    simpl.
    remember (fold_constants_aexp a1) as a1' eqn:Heqa1'.
    remember (fold_constants_aexp a2) as a2' eqn:Heqa2'.
    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.
    simpl. destruct (n <=? n0); reflexivity.
  - (* BNot *)
    simpl. remember (fold_constants_bexp b) as b' eqn:Heqb'.
    rewrite IHb.
    destruct b'; reflexivity.
  - (* BAnd *)
    simpl.
    remember (fold_constants_bexp b1) as b1' eqn:Heqb1'.
    remember (fold_constants_bexp b2) as b2' eqn:Heqb2'.
    rewrite IHb1. rewrite IHb2.
    destruct b1'; destruct b2'; reflexivity.
Qed.
(** [] *)

(** **** Exercise: 3 stars, standard (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.
  induction c; simpl.
  - (* skip *) apply refl_cequiv.
  - (* := *) apply CAsgn_congruence.
              apply fold_constants_aexp_sound.
  - (* ; *) apply CSeq_congruence; assumption.
  - (* if *)
    assert (bequiv b (fold_constants_bexp b)). {
      apply fold_constants_bexp_sound. }
    destruct (fold_constants_bexp b) eqn:Heqb;
      try (apply CIf_congruence; assumption).
      (* (If the optimization doesn't eliminate the if, then the
          result is easy to prove from the IH and
          [fold_constants_bexp_sound].) *)
    + (* b always true *)
      apply trans_cequiv with c1; try assumption.
      apply if_true; assumption.
    + (* b always false *)
      apply trans_cequiv with c2; try assumption.
      apply if_false; assumption.
  -
    assert (bequiv b (fold_constants_bexp b)). {
      apply fold_constants_bexp_sound. }
    destruct (fold_constants_bexp b) eqn:Heqb; try (apply CWhile_congruence; assumption).
    + apply while_true. assumption.
    + apply while_false. assumption.
Qed.
(** [] *)

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

(** **** Exercise: 4 stars, advanced, optional (optimize_0plus)

    Recall the definition [optimize_0plus] from the [Imp] chapter
    of _Logical Foundations_:

    Fixpoint optimize_0plus (a:aexp) : aexp :=
      match a with
      | ANum n =>
          ANum n
      | <{ 0 + a2 }> =>
          optimize_0plus a2
      | <{ a1 + a2 }> =>
          <{ (optimize_0plus a1) + (optimize_0plus a2) }>
      | <{ a1 - a2 }> =>
          <{ (optimize_0plus a1) - (optimize_0plus a2) }>
      | <{ a1 * a2 }> =>
          <{ (optimize_0plus a1) * (optimize_0plus a2) }>
      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,
   plus 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

    [] *)

Fixpoint optimize_0plus_aexp (a : aexp) : aexp :=
  match a with
  | ANum n       => ANum n
  | AId x        => AId x
  | <{ a1 + a2 }>  =>
    match (fold_constants_aexp a1,
           fold_constants_aexp a2)
    with
    | (ANum 0, ANum n) => ANum n
    | (a1', a2') => <{ a1' + a2' }>
    end
  | <{ a1 - a2 }> =>
    match (fold_constants_aexp a1,
           fold_constants_aexp a2)
    with
    | (ANum n1, ANum n2) => ANum (n1 - n2)
    | (a1', a2') => <{ a1' - a2' }>
    end
  | <{ a1 * a2 }>  =>
    match (fold_constants_aexp a1,
           fold_constants_aexp a2)
    with
    | (ANum n1, ANum n2) => ANum (n1 * n2)
    | (a1', a2') => <{ a1' * a2' }>
    end
  end.

(* ################################################################# *)
(** * Proving Inequivalence *)

(** 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.  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. *)

(** More formally, here is the function that substitutes an arithmetic
    expression [u] for each occurrence of a given variable [x] in
    another expression [a]: *)

Fixpoint subst_aexp (x : string) (u : aexp) (a : aexp) : aexp :=
  match a with
  | ANum n       =>
      ANum n
  | AId x'       =>
      if eqb_string x x' then u else AId x'
  | <{ a1 + a2 }>  =>
      <{ (subst_aexp x u a1) + (subst_aexp x u a2) }>
  | <{ a1 - a2 }> =>
      <{ (subst_aexp x u a1) - (subst_aexp x u a2) }>
  | <{ a1 * a2 }>  =>
      <{ (subst_aexp x u a1) * (subst_aexp x u a2) }>
  end.

Example subst_aexp_ex :
  subst_aexp X <{42 + 53}> <{Y + X}>
  = <{ Y + (42 + 53)}>.
Proof. simpl. 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 x1 x2 a1 a2,
  cequiv <{ x1 := a1; x2 := a2 }>
         <{ x1 := a1; x2 := subst_aexp x1 a1 a2 }>.

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

    We can show the following counterexample:

       X := X + 1; Y := X

    If we perform the substitution, we get

       X := X + 1; Y := X + 1

    which clearly isn't equivalent to the original program. [] *)

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 := X + 1;
              Y := X }>
      as c1.
  remember <{ X := X + 1;
              Y := X + 1 }>
      as c2.
  assert (cequiv c1 c2) by (subst; apply Contra).
  clear Contra.

  (* ... allows us to show that the command [c2] can terminate
     in two different final states:
        st1 = (Y !-> 1 ; X !-> 1)
        st2 = (Y !-> 2 ; X !-> 1). *)
  remember (Y !-> 1 ; X !-> 1) as st1.
  remember (Y !-> 2 ; X !-> 1) as st2.
  assert (H1 : empty_st =[ c1 ]=> st1);
  assert (H2 : empty_st =[ c2 ]=> st2);
  try (subst;
       apply E_Seq with (st' := (X !-> 1));
       apply E_Asgn; reflexivity).
  clear Heqc1 Heqc2.

  apply H in H1.
  clear H.

  (* Finally, we use the fact that evaluation is deterministic
     to obtain a contradiction. *)
  assert (Hcontra : st1 = st2)
    by (apply (ceval_deterministic c2 empty_st); assumption).
  clear H1 H2.

  assert (Hcontra' : st1 Y = st2 Y)
    by (rewrite Hcontra; reflexivity).
  subst. discriminate. Qed.

(** **** Exercise: 4 stars, standard, optional (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 : string) : 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 (<{ 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 (<{ 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 (<{ a1 * a2 }>).

Lemma aeval_weakening : forall x st a ni,
  var_not_used_in_aexp x a ->
  aeval (x !-> ni ; st) a = aeval st a.
Proof.
  intros.
  induction a; inversion H; simpl;
    repeat (first [rewrite IHa1 | rewrite IHa2 | reflexivity | assumption]).
    (* try rewrite IHa1; try rewrite IHa2; try reflexivity; try assumption; try assumption. *)
  - apply t_update_neq. assumption.
Qed.

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

Definition subst_equiv_property' := forall x1 x2 a1 a2,
  var_not_used_in_aexp x1 a1 ->
  cequiv <{ x1 := a1; x2 := a2 }>
  <{ x1 := a1; x2 := subst_aexp x1 a1 a2 }>.

Lemma not_used_subst_equal : forall x a1 a2 st,
  var_not_used_in_aexp x a1 ->
  aeval (x !-> aeval st a1; st) (subst_aexp x a1 a2) =
  aeval (x !-> aeval st a1; st) a2.
Proof.
  intros.
  induction a2; simpl; try (rewrite IHa2_1; rewrite IHa2_2); try reflexivity.
  - destruct (eqb_string x x0) eqn:Heqb.
    + rewrite aeval_weakening. rewrite eqb_string_true_iff in Heqb. rewrite Heqb.
      rewrite t_update_eq. reflexivity. assumption.
    + simpl. reflexivity.
Qed.

Theorem subst_equiv : subst_equiv_property'.
Proof.
  unfold subst_equiv_property'.
  intros. unfold cequiv. split; intros;
   inversion H0; subst; apply E_Seq with (st':=st'0); try assumption;
   inversion H3; inversion H6; subst.
  - rewrite <- not_used_subst_equal. apply E_Asgn. reflexivity. assumption.
  - rewrite not_used_subst_equal. apply E_Asgn. reflexivity. assumption.
Qed.
(* [] *)

(** **** Exercise: 3 stars, standard (inequiv_exercise)

    Prove that an infinite loop is not equivalent to [skip] *)

Theorem inequiv_exercise:
  ~ cequiv <{ while true do skip end }> <{ skip }>.
Proof.
  unfold not. unfold cequiv. intros Contra.
  remember (X !-> 1) as st.
  assert (st =[ skip ]=> st). {apply E_Skip.}
  apply Contra in H.
  apply  while_true_nonterm in H.
  inversion H.
  apply refl_bequiv.
Qed.
(** [] *)

(* ################################################################# *)
(** * Extended Exercise: Nondeterministic Imp *)

(** As we have seen (in theorem [ceval_deterministic] in the [Imp]
    chapter), Imp's evaluation relation is deterministic.  However,
    _non_-determinism is an important part of the definition of many
    real programming languages. For example, in many imperative
    languages (such as C and its relatives), the order in which
    function arguments are evaluated is unspecified.  The program
    fragment

      x = 0;
      f(++x, x)

    might call [f] with arguments [(1, 0)] or [(1, 1)], depending how
    the compiler chooses to order things.  This can be a little
    confusing for programmers, but it gives the compiler writer useful
    freedom.

    In this exercise, we will extend Imp with a simple
    nondeterministic command and study how this change affects
    program equivalence.  The new command has the syntax [HAVOC X],
    where [X] is an identifier. The effect of executing [HAVOC X] is
    to assign an _arbitrary_ number to the variable [X],
    nondeterministically. For example, after executing the program:

      HAVOC Y;
      Z := Y * 2

    the value of [Y] can be any number, while the value of [Z] is
    twice that of [Y] (so [Z] is always even). Note that we are not
    saying anything about the _probabilities_ of the outcomes -- just
    that there are (infinitely) many different outcomes that can
    possibly happen after executing this nondeterministic code.

    In a sense, a variable on which we do [HAVOC] roughly corresponds
    to an uninitialized variable in a low-level language like C.  After
    the [HAVOC], the variable holds a fixed but arbitrary number.  Most
    sources of nondeterminism in language definitions are there
    precisely because programmers don't care which choice is made (and
    so it is good to leave it open to the compiler to choose whichever
    will run faster).

    We call this new language _Himp_ (``Imp extended with [HAVOC]''). *)

Module Himp.

(** To formalize Himp, we first add a clause to the definition of
    commands. *)

Inductive com : Type :=
  | CSkip : com
  | CAsgn : string -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  | CHavoc : string -> com.                (* <--- NEW *)

Notation "'havoc' l" := (CHavoc l)
                          (in custom com at level 60, l constr at level 0).
Notation "'skip'"  :=
         CSkip (in custom com at level 0).
Notation "x := y"  :=
         (CAsgn x y)
            (in custom com at level 0, x constr at level 0,
             y at level 85, no associativity).
Notation "x ; y" :=
         (CSeq x y)
           (in custom com at level 90, right associativity).
Notation "'if' x 'then' y 'else' z 'end'" :=
         (CIf x y z)
           (in custom com at level 89, x at level 99,
            y at level 99, z at level 99).
Notation "'while' x 'do' y 'end'" :=
         (CWhile x y)
            (in custom com at level 89, x at level 99, y at level 99).

(** **** Exercise: 2 stars, standard (himp_ceval)

    Now, we must extend the operational semantics. We have provided
   a template for the [ceval] relation below, specifying the big-step
   semantics. What rule(s) must be added to the definition of [ceval]
   to formalize the behavior of the [HAVOC] command? *)

Reserved Notation "st '=[' c ']=>' st'"
         (at level 40, c custom com at level 99, st constr,
          st' constr at next level).

Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st,
      st =[ skip ]=> st
  | E_Asgn  : forall st a n x,
      aeval st a = n ->
      st =[ x := a ]=> (x !-> n ; st)
  | E_Seq : forall c1 c2 st st' st'',
      st  =[ c1 ]=> st'  ->
      st' =[ c2 ]=> st'' ->
      st  =[ c1 ; c2 ]=> st''
  | E_IfTrue : forall st st' b c1 c2,
      beval st b = true ->
      st =[ c1 ]=> st' ->
      st =[ if b then c1 else c2 end ]=> st'
  | E_IfFalse : forall st st' b c1 c2,
      beval st b = false ->
      st =[ c2 ]=> st' ->
      st =[ if b then c1 else c2 end ]=> st'
  | E_WhileFalse : forall b st c,
      beval st b = false ->
      st =[ while b do c end ]=> st
  | E_WhileTrue : forall st st' st'' b c,
      beval st b = true ->
      st  =[ c ]=> st' ->
      st' =[ while b do c end ]=> st'' ->
      st  =[ while b do c end ]=> st''
  | E_Havoc : forall st x n,
      st =[ havoc x ]=> (x !-> n; st)

where "st =[ c ]=> st'" := (ceval c st st').

(** As a sanity check, the following claims should be provable for
    your definition: *)

Example havoc_example1 : empty_st =[ havoc X ]=> (X !-> 0).
Proof.
  apply E_Havoc.
Qed.

Example havoc_example2 :
  empty_st =[ skip; havoc Z ]=> (Z !-> 42).
Proof.
  intros.
  apply E_Seq with (st':=empty_st).
  apply E_Skip.
  apply E_Havoc.
Qed.

(* Do not modify the following line: *)
Definition manual_grade_for_Check_rule_for_HAVOC : option (nat*string) := None.
(** [] *)

(** Finally, we repeat the definition of command equivalence from above: *)

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

(** Let's apply this definition to prove some nondeterministic
    programs equivalent / inequivalent. *)

(** **** Exercise: 3 stars, standard (havoc_swap)

    Are the following two programs equivalent? *)

Definition pXY :=
  <{ havoc X ; havoc Y }>.

Definition pYX :=
  <{ havoc Y; havoc X }>.

(** If you think they are equivalent, prove it. If you think they are
    not, prove that. *)

Theorem pXY_cequiv_pYX :
  cequiv pXY pYX \/ ~cequiv pXY pYX.
Proof.
  left.
  unfold cequiv. unfold pXY. unfold pYX. split; intros;
   inversion H; inversion H2; inversion H5; subst.
  - apply E_Seq with (st':= Y !-> n0; st).
    apply E_Havoc. rewrite t_update_permute. apply E_Havoc.
    unfold not. intro.  inversion H0.
  - apply E_Seq with (st':= X !-> n0; st).
    apply E_Havoc. rewrite t_update_permute. apply E_Havoc.
    unfold not. intro.  inversion H0.
Qed.
(** [] *)

(** **** Exercise: 4 stars, standard, optional (havoc_copy)

    Are the following two programs equivalent? *)

Definition ptwice :=
  <{ havoc X; havoc Y }>.

Definition pcopy :=
  <{ havoc X; Y := X }>.

(** If you think they are equivalent, then prove it. If you think they
    are not, then prove that.  (Hint: You may find the [assert] tactic
    useful.) *)

Ltac string_neq :=
  unfold not; intro Contra_string_eq; inversion Contra_string_eq.

Theorem ptwice_cequiv_pcopy :
  cequiv ptwice pcopy \/ ~cequiv ptwice pcopy.
Proof.
  right.
  unfold not. unfold cequiv.  intro Contra.
  remember (Y !-> 1; X !-> 0) as st'1.
  remember (Y !-> 0; X !-> 0) as st'2.

  assert (H1 : empty_st =[ ptwice ]=> st'1).
  {apply E_Seq with (st' := (X !-> 0)). apply E_Havoc. rewrite Heqst'1.  apply E_Havoc.}
  assert (H2 : empty_st =[ pcopy ]=> st'2).
  {apply E_Seq with (st' := (X !-> 0)). apply E_Havoc. rewrite Heqst'2. apply E_Asgn. simpl. apply t_update_eq. }

  apply Contra in H1. inversion H1. inversion H6. subst.
  assert ((Y !-> aeval st' X; st') Y = (Y !-> 1; X !-> 0) Y). { rewrite H10; reflexivity. }
  repeat rewrite t_update_eq in H.
  assert ((Y !-> aeval st' X; st') X = (Y !-> 1; X !-> 0) X). { rewrite H10; reflexivity. }
  do 2 rewrite t_update_neq in H0. rewrite t_update_eq in H0. simpl in H. rewrite H in H0.
  inversion H0. auto.
  string_neq. string_neq. string_neq.
Qed.
(** [] *)

(** The definition of program equivalence we are using here has some
    subtle consequences on programs that may loop forever.  What
    [cequiv] says is that the set of possible _terminating_ outcomes
    of two equivalent programs is the same. However, in a language
    with nondeterminism, like Himp, some programs always terminate,
    some programs always diverge, and some programs can
    nondeterministically terminate in some runs and diverge in
    others. The final part of the following exercise illustrates this
    phenomenon.
*)

(** **** Exercise: 4 stars, advanced (p1_p2_term)

    Consider the following commands: *)

Definition p1 : com :=
  <{ while ~ (X = 0) do
       havoc Y;
       X := X + 1
     end }>.

Definition p2 : com :=
  <{ while ~ (X = 0) do
       skip
     end }>.

(** Intuitively, [p1] and [p2] have the same termination behavior:
    either they loop forever, or they terminate in the same state they
    started in.  We can capture the termination behavior of [p1] and
    [p2] individually with these lemmas: *)

Theorem eqb_refl : forall n,
    n =? n = true.
Proof.
  intro n.
  induction n; auto.
Qed.

Theorem eqb_true : forall n m,
  n =? m = true <-> n = m.
Proof.
  intros. split.
  - generalize dependent m. induction n; intro m; destruct m.
    + reflexivity.
    + intros. inversion H.
    + intro H. inversion H.
    + intros. apply f_equal. apply IHn. simpl in H. apply H.
  -
    intros. rewrite H.
    apply eqb_refl.
Qed.

Lemma p1_may_diverge : forall st st', st X <> 0 ->
  ~ st =[ p1 ]=> st'.
Proof.
  unfold not. unfold p1. intros st st' Hstneq0. intro Contra.
  remember <{ while ~ X = 0 do havoc Y; X := X + 1 end }> as cw eqn:Heqcw.
  induction Contra; inversion Heqcw; subst. clear Heqcw.
  -
    simpl in H. apply negb_false_iff in H. apply eqb_true in H.
    apply Hstneq0 in H. inversion H.
  -
    assert  (Hrefl : <{ while ~ X = 0 do havoc Y; X := X + 1 end }> =
             <{ while ~ X = 0 do havoc Y; X := X + 1 end }>). { reflexivity. }
    apply IHContra2 in Hrefl as Contra. inversion Contra.
    inversion Contra1. inversion H2. inversion H5. subst. intro Hevalx.
    rewrite t_update_eq in Hevalx. simpl in Hevalx. rewrite t_update_neq in Hevalx.
    + destruct (st X) in Hevalx. inversion Hevalx. inversion Hevalx.
    + string_neq.
Qed.

Lemma p2_may_diverge : forall st st', st X <> 0 ->
  ~ st =[ p2 ]=> st'.
Proof.
  unfold not. unfold p2. intros st st' Hstneq0. intro Contra.
  remember <{ while ~ X = 0 do skip end}> as cw eqn:Heqcw.
  induction Contra; inversion Heqcw; subst. clear Heqcw.
  -
    simpl in H. apply negb_false_iff in H. apply eqb_true in H.
    apply Hstneq0 in H. inversion H.
  -
    assert (Hrefl: <{ while ~ X = 0 do skip end }>
                   = <{ while ~ X = 0 do skip end }>). { reflexivity. }
    apply IHContra2 in Hrefl as Contra. inversion Contra.
    inversion Contra1. subst. apply Hstneq0.
Qed.
(** [] *)

(** **** Exercise: 4 stars, advanced (p1_p2_equiv)

    Use these two lemmas to prove that [p1] and [p2] are actually
    equivalent. *)

Theorem p1_p2_equiv : cequiv p1 p2.
Proof.
  intros. unfold cequiv. split; intros; inversion H; subst.
  -
    unfold p1 in H. unfold p2. inversion H; subst. apply E_WhileFalse. assumption.
    rewrite H2 in H4. inversion H4.
  -
    apply p1_may_diverge in H. inversion H. simpl in H2. unfold not. intro.
    apply eqb_true in H0. rewrite H0 in H2. inversion H2.
  -
    unfold p2 in H. unfold p2. inversion H; subst. apply E_WhileFalse. assumption.
    rewrite H2 in H4. inversion H4.
  -
    apply p2_may_diverge in H. inversion H. simpl in H2. unfold not.
    intro. apply eqb_true in H0. rewrite H0 in H2. inversion H2.
Qed.
(** [] *)

(** **** Exercise: 4 stars, advanced (p3_p4_inequiv)

    Prove that the following programs are _not_ equivalent.  (Hint:
    What should the value of [Z] be when [p3] terminates?  What about
    [p4]?) *)

Definition p3 : com :=
  <{ Z := 1;
     while ~(X = 0) do
       havoc X;
       havoc Z
     end }>.

Definition p4 : com :=
  <{ X := 0;
     Z := 1 }>.

Theorem p3_p4_inequiv : ~ cequiv p3 p4.
Proof.
  unfold not, cequiv. intro Contra.
  remember (X !-> 1) as st0.
  remember (Z !-> 0; X !-> 0; Z !-> 1; X !-> 1) as st1.
  remember (Z !-> 1; X !-> 0; X !-> 1) as st2.
  assert (H1: st0 =[ p3 ]=> st1). {
    unfold p3. rewrite Heqst0.
    apply E_Seq with (st':=(Z !-> 1; X !-> 1)).
    apply E_Asgn. auto.
    apply E_WhileTrue with (st':=(Z !-> 0; X !-> 0; Z !-> 1; X !-> 1)). auto.
    apply E_Seq with (st':= (X !-> 0; Z !-> 1; X !-> 1)); apply E_Havoc.
    rewrite Heqst1. apply E_WhileFalse. auto.
  }
  apply Contra in H1.
  inversion H1. subst. inversion H5. subst.
  simpl in H6.
  assert (1 = 0).
  { replace 1 with ((Z !-> 1; st') Z) at 1.
    replace 0 with ((Z !-> 0; X !-> 0; Z !-> 1; X !-> 1) Z) at 2.
    rewrite H6. auto.
    apply t_update_eq.
    apply t_update_eq.
  }
  inversion H.
Qed.
(** [] *)

(** **** Exercise: 5 stars, advanced, optional (p5_p6_equiv)

    Prove that the following commands are equivalent.  (Hint: As
    mentioned above, our definition of [cequiv] for Himp only takes
    into account the sets of possible terminating configurations: two
    programs are equivalent if and only if the set of possible terminating
    states is the same for both programs when given a same starting state
    [st].  If [p5] terminates, what should the final state be? Conversely,
    is it always possible to make [p5] terminate?) *)

Definition p5 : com :=
  <{ while ~(X = 1) do
       havoc X
     end }>.

Definition p6 : com :=
  <{ X := 1 }>.

Theorem p5_p6_equiv : cequiv p5 p6.
Proof.
  unfold cequiv. unfold p5. unfold p6. split; intros.
  -
    remember <{while ~ X = 1 do havoc X end }> as cwhile eqn:Heqcwhile.
    induction H; inversion Heqcwhile; subst.
    +
      simpl in H. apply negb_false_iff in H. apply eqb_true in H.
      assert (st = (X !-> 1; st)).
      {
        rewrite <- H.
        rewrite t_update_same.
        reflexivity.
      }
      rewrite H0 at 2. apply E_Asgn.
      simpl. reflexivity.
    + inversion H0. subst.
      apply IHceval2 in Heqcwhile. inversion Heqcwhile. subst. simpl. simpl in Heqcwhile.
      rewrite t_update_shadow. apply E_Asgn.
      auto.
  - inversion H. subst. simpl.
    destruct (st X =? 1) eqn:Heqstx0.
    + apply eqb_true in Heqstx0. rewrite <- Heqstx0 at 2.
      rewrite t_update_same.
      apply E_WhileFalse.
      simpl. apply negb_false_iff. apply eqb_true. assumption.
    + apply E_WhileTrue with (X !-> 1; st).
      * simpl. apply negb_true_iff. assumption.
      * apply E_Havoc.
      * apply E_WhileFalse. simpl. reflexivity.
Qed.

(** [] *)

End Himp.

Module Fimp.

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

(** **** Exercise: 4 stars, standard, optional (for_while_equiv)

    This exercise extends the optional [add_for_loop] exercise from
    the [Imp] chapter, 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
*)

Inductive com : Type :=
  | CSkip : com
  | CAsgn : string -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  | CFor: com -> bexp -> com -> com -> com.

Notation "'skip'"  :=
         CSkip (in custom com at level 0).
Notation "x := y"  :=
         (CAsgn x y)
            (in custom com at level 0, x constr at level 0,
             y at level 85, no associativity).
Notation "x ; y" :=
         (CSeq x y)
           (in custom com at level 90, right associativity).
Notation "'if' x 'then' y 'else' z 'end'" :=
         (CIf x y z)
           (in custom com at level 89, x at level 99,
            y at level 99, z at level 99).
Notation "'while' x 'do' y 'end'" :=
         (CWhile x y)
           (in custom com at level 89, x at level 99, y at level 99).
Notation "'for'  ( c1 ';;' b ';;' c2 ) c3" :=
         (CFor c1 b c2 c3)
           (in custom com at level 89, c1 at level 99, b at level 99, c2 at level 99, c3 at level 99).

Reserved Notation "st '=[' c ']=>' st'"
         (at level 40, c custom com at level 99, st constr,
          st' constr at next level).

Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st,
      st =[ skip ]=> st
  | E_Asgn  : forall st a n x,
      aeval st a = n ->
      st =[ x := a ]=> (x !-> n ; st)
  | E_Seq : forall c1 c2 st st' st'',
      st  =[ c1 ]=> st'  ->
      st' =[ c2 ]=> st'' ->
      st  =[ c1 ; c2 ]=> st''
  | E_IfTrue : forall st st' b c1 c2,
      beval st b = true ->
      st =[ c1 ]=> st' ->
      st =[ if b then c1 else c2 end ]=> st'
  | E_IfFalse : forall st st' b c1 c2,
      beval st b = false ->
      st =[ c2 ]=> st' ->
      st =[ if b then c1 else c2 end ]=> st'
  | E_WhileFalse : forall b st c,
      beval st b = false ->
      st =[ while b do c end ]=> st
  | E_WhileTrue : forall st st' st'' b c,
      beval st b = true ->
      st  =[ c ]=> st' ->
      st' =[ while b do c end ]=> st'' ->
      st  =[ while b do c end ]=> st''
  | E_For: forall st st' st'' b c1 c2 c3,
      st  =[ c1 ]=> st' ->
      st' =[ while b do (c3 ; c2) end]=> st'' ->
      st  =[ for (c1 ;; b ;; c2) c3 ]=> st''
where "st =[ c ]=> st'" := (ceval c st st').

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

Theorem for_while_cequiv : forall b c1 c2 c3,
  cequiv <{ c1 ; while b do (c3 ; c2) end }>
         <{ for (c1 ;; b ;; c2) c3 }>.
Proof.
  unfold cequiv. split; intros.
  - inversion H. subst.
    apply E_For with (st':=st'0); assumption.
  - inversion H. subst.
    apply E_Seq with (st':=st'0); assumption.
Qed.

End Fimp.

(** **** Exercise: 3 stars, standard, optional (swap_noninterfering_assignments)

    (Hint: You'll need [functional_extensionality] for this one.) *)

Lemma neqb_string_symm: forall (x y: string), x <> y <-> y <> x.
Proof.
  unfold not. intros; split; intros Contra Heqxy; symmetry in Heqxy; apply Contra in Heqxy; inversion Heqxy.
Qed.

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.
  assert (A:  forall l1 l2 a1 a2 st st',
      l1 <> l2 -> var_not_used_in_aexp l1 a2 ->
      var_not_used_in_aexp l2 a1 ->
      st =[ l1:=a1; l2:=a2 ]=> st' ->
      st =[ l2:=a2; l1:=a1 ]=> st').
  {
    intros.
    inversion H2. inversion H5. inversion H8. subst.
    apply E_Seq with (st':=(l2 !-> aeval st a2; st)).
    apply E_Asgn. reflexivity.
    assert (forall l, (l2 !-> aeval (l1 !-> aeval st a1; st) a2; l1 !-> aeval st a1; st) l =
                 (l1 !-> aeval (l2 !-> aeval st a2; st) a1; l2 !-> aeval st a2; st) l).
    {
      intro l. destruct (eqb_string l l1) eqn:Heqll1.
      -
        apply eqb_string_true_iff in Heqll1. subst. rewrite t_update_neq.
        do 2 rewrite t_update_eq. rewrite aeval_weakening; auto. auto.
      -
        destruct (eqb_string l l2) eqn:Heqll2.
        +
          apply eqb_string_true_iff in Heqll2. subst. apply eqb_string_false_iff in Heqll1.
          rewrite t_update_eq. rewrite t_update_neq.
          rewrite t_update_eq. apply aeval_weakening. assumption. assumption.
        +
          apply eqb_string_false_iff in Heqll1. apply eqb_string_false_iff in Heqll2.
          apply neqb_string_symm in Heqll1. apply neqb_string_symm in Heqll2.
          repeat (rewrite t_update_neq; try assumption). reflexivity.
    }.
    apply functional_extensionality in H3.
    rewrite H3.
    apply E_Asgn. reflexivity.
  }.
  unfold cequiv. split; intros.
  -
    apply A; try assumption.
  -
    apply A; try assumption. apply neqb_string_symm. assumption.
Qed.
(** [] *)

(** **** Exercise: 4 stars, advanced, optional (capprox)

    In this exercise we define an asymmetric variant of program
    equivalence we call _program approximation_. We say that a
    program [c1] _approximates_ a program [c2] when, for each of
    the initial states for which [c1] terminates, [c2] also terminates
    and produces the same final state. Formally, program approximation
    is defined as follows: *)

Definition capprox (c1 c2 : com) : Prop := forall (st st' : state),
  st =[ c1 ]=> st' -> st =[ c2 ]=> st'.

(** For example, the program

  c1 = while ~(X = 1) do
         X := X - 1
       end

    approximates [c2 = X := 1], but [c2] does not approximate [c1]
    since [c1] does not terminate when [X = 0] but [c2] does.  If two
    programs approximate each other in both directions, then they are
    equivalent. *)

(** Find two programs [c3] and [c4] such that neither approximates
    the other. *)

Definition c3 : com := <{ X := 0 }>.

Definition c4 : com := <{ X := 1 }>.

Theorem c3_c4_different : ~ capprox c3 c4 /\ ~ capprox c4 c3.
Proof.
  assert (A: forall x, (x !-> 0) = (x !-> 1) -> 0 = 1).  {
    intros.
    replace 0 with ((x !-> 0) x) at 1.
    replace 1 with ((x !-> 1) x) at 1.
    rewrite H. reflexivity.
    apply t_update_eq. apply t_update_eq. }
  unfold not. unfold capprox. unfold c3. unfold c4.
  split; intros;
  remember (X !-> 0) as st1;
  remember (X !-> 1) as st2;
  assert (H1 : empty_st =[ X := 0 ]=> (X !-> 0));
  assert (H2 : empty_st =[ X := 1 ]=> (X !-> 1));
  try (apply E_Asgn; auto);
    try (apply H in H1 as Contra || apply H in H2 as Contra); inversion Contra; subst; simpl in H6.
  - symmetry in H6. apply A in H6. inversion H6.
  - apply A in H6. inversion H6.
Qed.

(** Find a program [cmin] that approximates every other program. *)

Definition cmin : com := <{ while true do skip end }>.

Theorem cmin_minimal : forall c, capprox cmin c.
Proof.
  unfold capprox. unfold cmin. intros.
  apply while_true_nonterm in H. inversion H.
  apply refl_bequiv.
Qed.

(** Finally, find a non-trivial property which is preserved by
    program approximation (when going from left to right). *)

Definition zprop (c : com) : Prop := forall st,
    exists st', st =[ c ]=> st'.

Theorem zprop_preserving : forall c c',
  zprop c -> capprox c c' -> zprop c'.
Proof.
  unfold zprop. unfold capprox. intros.
  destruct (H st) as [st' Hexist].
  exists st'. apply H0. assumption.
Qed.

(* 2021-08-11 15:11 *)


(*This file contains functions and their properties related to total quantities.*)

Require Import Wellfounded List Arith  Lia.
Require Import ssreflect ssrbool.
Require Export Lists.List.
Require Export GenReflect SetSpecs.
Require Export DecSort MinMax.
Require Export mBidAsk.
Require Export DecList.

Section quantity.

(* Sum of total quantities of a bid and ask in fill_type and their properties *)

Fixpoint ttqb (F: list fill_type) (b:Bid) : (nat) :=
  match F with
  |nil => 0
  |f::F'=> match (b_eqb b (bid_of f)) with
      |true =>  (tq f)+(ttqb F' b)
      |false => (ttqb F' b)
  end
  end.

Lemma ttqb_elim (M:list fill_type) (b:Bid) : ~In b (bids_of M) -> ttqb M b = 0.
Proof. intros. induction M. simpl. auto. simpl in H.
simpl. destruct (b_eqb b (bid_of a)) eqn: Hb. move /eqP in Hb. symmetry in Hb.
destruct H. left. auto. destruct IHM. intro. destruct H. right. exact H0.
auto. Qed.

Lemma ttqb_intro (M:list fill_type) (b:Bid)(NZT: forall m, In m M -> tq m>0):
ttqb M b = 0 -> ~In b (bids_of M).
Proof. revert b. induction M. simpl. auto.
intros. simpl in H. destruct (b_eqb b (bid_of a)) eqn: Hb.
assert (tq a >0). eapply NZT. auto. lia. simpl.
intro. destruct H0.  subst b.  move /eqP in Hb.
elim Hb. auto. revert H0. eapply IHM. auto. exact. Qed.

Lemma ttqb_intro1 (M:list fill_type) (b:Bid):
ttqb M b <> 0 -> In b (bids_of M).
Proof. revert b. induction M. simpl. auto.
intros. simpl in H. destruct (b_eqb b (bid_of a)) eqn: Hb. simpl.
move /eqP in Hb. subst. auto. apply IHM in H. simpl. auto. Qed.

Lemma ttqb_delete_m_ofb
(M:list fill_type) (m:fill_type) (b:Bid) :
In m M -> b=bid_of m -> ttqb M b = ttqb (delete m M) b + tq m.
Proof. intros. induction M as [|m' M']. elim H.
simpl. destruct (b_eqb b (bid_of m')) eqn: Hb.
destruct H. subst m.
replace (m_eqb m' m') with true. lia. auto.
destruct (m_eqb m m') eqn:Hmm.
move /eqP in Hmm. subst m. lia.
simpl. rewrite Hb. rewrite IHM'.
auto. lia.
destruct H. subst m. subst b.
move /eqP in Hb. elim Hb. auto.
simpl.
destruct (m_eqb m m') eqn:Hmm.
move /eqP in Hmm. subst m. subst b.
move /eqP in Hb. elim Hb. auto.
simpl.
rewrite Hb. rewrite IHM'.
auto. lia. Qed.

Lemma ttqb_delete_m_not_ofb
(M:list fill_type) (m:fill_type) (b:Bid) :
In m M -> b<>bid_of m -> ttqb M b = ttqb (delete m M) b.
Proof. intros. induction M as [|m' M']. elim H.
simpl. destruct (b_eqb b (bid_of m')) eqn: Hb.
destruct H. subst m.
move /eqP in Hb. subst b.
elim H0. auto.
destruct (m_eqb m m') eqn:Hmm.
move /eqP in Hmm. subst m.
move /eqP in Hb. subst b.
elim H0. auto.
simpl. rewrite Hb. rewrite IHM'.
auto. lia.
destruct H. subst m.
replace (m_eqb m' m' ) with true.
auto. eauto.
destruct (m_eqb m m') eqn:Hmm. auto.
simpl.
rewrite Hb. rewrite IHM'.
auto. lia. Qed.

Lemma ttqb_equal_implies_subet (M1 M2:list fill_type)
(NZT:forall m : fill_type, In m M1 -> tq m > 0):
(forall b, ttqb M1 b = ttqb M2 b) -> (bids_of M1) [<=] (bids_of M2).
Proof. unfold "[<=]".
       intros. assert(In a (bids_of M2)\/~In a (bids_of M2)).
       eauto. destruct H1. auto.
       specialize (H a).
       apply ttqb_elim in H1. rewrite H1 in H.
       apply ttqb_intro in H. unfold not in H.
       apply H in H0. elim H0. eauto. Qed.

Lemma ttqb_of_perm (M1 M2:list fill_type)
(*(NZT:forall m : fill_type, In m M1 -> tq m > 0)*):
perm M1 M2 -> (forall b, ttqb M1 b = ttqb M2 b).
Proof. Proof. revert M2. induction M1.
intros. unfold perm in H.
move /andP in H. destruct H.
assert(M2=nil).
eauto. rewrite H1. auto.
intros. unfold perm in H.
move /andP in H. destruct H.
simpl. destruct(b_eqb b (bid_of a)) eqn:Ha.
{
move /eqP in Ha.
assert(In a M2). eauto.
eapply ttqb_delete_m_ofb with (M:=M2) in Ha.
rewrite Ha. cut(ttqb M1 b = ttqb (delete a M2) b).
lia.
apply included_elim3a with (a0:=a) in H.
simpl in H. replace (m_eqb a a) with true in H.
apply included_elim3a with (a0:=a) in H0.
simpl in H0. replace (m_eqb a a) with true in H0.
assert(perm M1 (delete a M2)).
unfold perm. apply /andP. auto.
apply IHM1 with (b:=b) in H2. lia.
eauto. eauto. eauto.
}
{ move /eqP in Ha. eapply ttqb_delete_m_not_ofb with (M:=M2) in Ha.
apply included_elim3a with (a0:=a) in H.
simpl in H. replace (m_eqb a a) with true in H.
apply included_elim3a with (a0:=a) in H0.
simpl in H0. replace (m_eqb a a) with true in H0.
assert(perm M1 (delete a M2)).
unfold perm. apply /andP. auto. rewrite Ha.
apply IHM1 with (b:=b) in H1. lia.
eauto. eauto. eauto.
} Qed.

Fixpoint ttqa (F: list fill_type) (a:Ask) : (nat) :=
  match F with
  |nil => 0
  |f::F'=> match (a_eqb a (ask_of f)) with
      |true =>  (tq f)+(ttqa F' a)
      |false => (ttqa F' a)
  end
  end.

Lemma ttqa_elim (M:list fill_type) (a:Ask) : ~In a (asks_of M) -> ttqa M a = 0.
Proof. intros. induction M. simpl. auto. simpl in H.
simpl. destruct (a_eqb a (ask_of a0)) eqn: Ha. move /eqP in Ha. symmetry in Ha.
destruct H. left. auto. destruct IHM. intro. destruct H. right. exact H0.
auto. Qed.

Lemma ttqa_intro (M:list fill_type) (a:Ask)(NZT: forall m, In m M -> tq m>0):
ttqa M a = 0 -> ~In a (asks_of M).
Proof. revert a. induction M. simpl. auto.
intros. simpl in H. destruct (a_eqb a0 (ask_of a)) eqn: Hb.
assert (tq a >0). eapply NZT. auto. lia. simpl.
intro. destruct H0.  subst a0.  move /eqP in Hb.
elim Hb. auto. revert H0. eapply IHM. auto. exact. Qed.

Lemma ttqa_intro1 (M:list fill_type) (a:Ask):
ttqa M a <> 0 -> In a (asks_of M).
Proof. revert a. induction M. simpl. auto.
intros. simpl in H. destruct (a_eqb a0 (ask_of a)) eqn: Hb. simpl.
move /eqP in Hb. subst a0. auto. apply IHM in H. simpl. auto. Qed.

Lemma ttqa_delete_m_ofa
(M:list fill_type) (m:fill_type) (a:Ask) :
In m M -> a=ask_of m -> ttqa M a = ttqa (delete m M) a + tq m.
Proof. intros. induction M as [|m' M']. elim H.
simpl. destruct (a_eqb a (ask_of m')) eqn: Ha.
destruct H. subst m.
replace (m_eqb m' m') with true. lia. auto.
destruct (m_eqb m m') eqn:Hmm.
move /eqP in Hmm. subst m. lia.
simpl. rewrite Ha. rewrite IHM'.
auto. lia.
destruct H. subst m. subst a.
move /eqP in Ha. elim Ha. auto.
simpl.
destruct (m_eqb m m') eqn:Hmm.
move /eqP in Hmm. subst m. subst a.
move /eqP in Ha. elim Ha. auto.
simpl.
rewrite Ha. rewrite IHM'.
auto. lia. Qed.

Lemma ttqa_delete_m_not_ofa
(M:list fill_type) (m:fill_type) (a:Ask) :
In m M -> a<>ask_of m -> ttqa M a = ttqa (delete m M) a.
Proof. intros. induction M as [|m' M']. elim H.
simpl. destruct (a_eqb a (ask_of m')) eqn: Ha.
destruct H. subst m.
move /eqP in Ha. subst a.
elim H0. auto.
destruct (m_eqb m m') eqn:Hmm.
move /eqP in Hmm. subst m.
move /eqP in Ha. subst a.
elim H0. auto.
simpl. rewrite Ha. rewrite IHM'.
auto. lia.
destruct H. subst m.
replace (m_eqb m' m' ) with true.
auto. eauto.
destruct (m_eqb m m') eqn:Hmm. auto.
simpl.
rewrite Ha. rewrite IHM'.
auto. lia. Qed.

Lemma ttqa_equal_implies_subet (M1 M2:list fill_type)
(NZT:forall m : fill_type, In m M1 -> tq m > 0):
(forall a, ttqa M1 a = ttqa M2 a) -> (asks_of M1) [<=] (asks_of M2).
Proof. unfold "[<=]".
       intros. assert(In a (asks_of M2)\/~In a (asks_of M2)).
       eauto. destruct H1. auto.
       specialize (H a).
       apply ttqa_elim in H1. rewrite H1 in H.
       apply ttqa_intro in H. unfold not in H.
       apply H in H0. elim H0. eauto. Qed.

Lemma ttqa_of_perm (M1 M2:list fill_type)
(*(NZT:forall m : fill_type, In m M1 -> tq m > 0)*):
perm M1 M2 -> (forall a, ttqa M1 a = ttqa M2 a).
Proof. Proof. revert M2. induction M1.
intros. unfold perm in H.
move /andP in H. destruct H.
assert(M2=nil).
eauto. rewrite H1. auto.
intros. unfold perm in H.
move /andP in H. destruct H.
simpl. destruct(a_eqb a0 (ask_of a)) eqn:Ha.
{
move /eqP in Ha.
assert(In a M2). eauto.
eapply ttqa_delete_m_ofa with (M:=M2) in Ha.
rewrite Ha. cut(ttqa M1 a0 = ttqa (delete a M2) a0).
lia.
apply included_elim3a with (a1:=a) in H.
simpl in H. replace (m_eqb a a) with true in H.
apply included_elim3a with (a1:=a) in H0.
simpl in H0. replace (m_eqb a a) with true in H0.
assert(perm M1 (delete a M2)).
unfold perm. apply /andP. auto.
apply IHM1 with (a:=a0) in H2. lia.
eauto. eauto. eauto.
}
{ move /eqP in Ha. eapply ttqa_delete_m_not_ofa with (M:=M2) in Ha.
apply included_elim3a with (a1:=a) in H.
simpl in H. replace (m_eqb a a) with true in H.
apply included_elim3a with (a1:=a) in H0.
simpl in H0. replace (m_eqb a a) with true in H0.
assert(perm M1 (delete a M2)).
unfold perm. apply /andP. auto. rewrite Ha.
apply IHM1 with (a:=a0) in H1. lia.
eauto. eauto. eauto.
} Qed.

Fixpoint ttq_ab (F: list fill_type) (b:Bid)(a:Ask) : (nat) :=
  match F with
  |nil => 0
  |f::F'=> match ((a_eqb a (ask_of f)) && (b_eqb b (bid_of f))) with
                |true => (tq f)+(ttq_ab F' b a)
                |false => (ttq_ab F' b a)
  end
end.

Hint Immediate ttqb_elim ttqa_elim: core.
Hint Resolve ttqb_intro ttqa_intro : core.
Hint Resolve ttqb_delete_m_not_ofb ttqb_delete_m_ofb : core.
Hint Resolve ttqa_delete_m_not_ofa ttqa_delete_m_ofa : core.

Lemma ttq_ab_elim_a (M:list fill_type)(b:Bid) (a:Ask) :
~In a (asks_of M) -> ttq_ab M b a = 0.
Proof. intros. induction M. { simpl. auto. }
{ simpl in H.
simpl. destruct (a_eqb a (ask_of a0) && b_eqb b (bid_of a0)) eqn: Hab.
{ move /andP in Hab.
destruct Hab.   move /eqP in H0.
 move /eqP in H1. destruct H. left. auto. }
{ apply IHM. revert H. eauto. } } Qed.

Lemma ttq_ab_elim_b (M:list fill_type)(b:Bid) (a:Ask) :
~In b (bids_of M) -> ttq_ab M b a = 0.
Proof. intros. induction M. { simpl. auto. }
{ simpl in H.
simpl. destruct (a_eqb a (ask_of a0) && b_eqb b (bid_of a0)) eqn: Hab.
{ move /andP in Hab.
destruct Hab.   move /eqP in H0.
 move /eqP in H1. destruct H. left. auto. }
{ apply IHM. revert H. eauto. } } Qed.

Hint Resolve ttq_ab_elim_b ttq_ab_elim_a : core.

Lemma ttqa_intro_ba (M:list fill_type) (b:Bid)(a:Ask)(NZT: forall m, In m M -> tq m>0):
ttq_ab M b a = 0 -> (forall m, In m M ->(b=bid_of m -> a<>ask_of m)).
Proof. revert a b. induction M.
{ simpl. auto. }
{
intros. simpl in H.
destruct (a_eqb a0 (ask_of a) && b_eqb b (bid_of a)) eqn: Hab.
{
assert (tq a >0). eapply NZT. auto.
  lia. }
  destruct H0.
  subst a.  move /andP in Hab. subst b. eauto.

  apply IHM with (m:=m) in H. auto. auto.
  auto. auto. } Qed.

Lemma ttqa_intro_ab (M:list fill_type)(b:Bid) (a:Ask)(NZT: forall m, In m M -> tq m>0):
ttq_ab M b a = 0 -> (forall m, In m M ->(a=ask_of m -> b<>bid_of m)).

Proof. revert a b. induction M.
{ simpl. auto. }
{
intros. simpl in H.
destruct (a_eqb a0 (ask_of a) && b_eqb b (bid_of a)) eqn: Hab.
{
assert (tq a >0). eapply NZT. auto.
  lia. }
  destruct H0.
  subst a.  move /andP in Hab. subst a0. eauto.

  apply IHM with (m:=m) in H. auto. auto.
  auto. auto. } Qed.

Hint Immediate ttqa_intro_ab ttqa_intro_ba: core.

Lemma ttq_ab_le_ttqa (M:list fill_type)(b:Bid)(a:Ask):
ttq_ab M b a <= ttqa M a.
Proof. revert a. induction M. intros. simpl. auto.
intros. simpl.
destruct (a_eqb a0 (ask_of a)) eqn:Ha0a;destruct (b_eqb b (bid_of a)) eqn: Hba.
{ simpl. cut(ttq_ab M b a0 <= ttqa M a0). lia. eapply IHM. }
{ simpl. cut(ttq_ab M b a0 <= ttqa M a0). lia. eapply IHM. }
{ simpl. eapply IHM. }
{ simpl. eapply IHM. }
Qed.

Lemma ttq_ab_le_ttqb (M:list fill_type)(b:Bid)(a:Ask):
ttq_ab M b a <= ttqb M b.
Proof. revert a. induction M. intros. simpl. auto.
intros. simpl.
destruct (a_eqb a0 (ask_of a)) eqn:Ha0a;destruct (b_eqb b (bid_of a)) eqn: Hba.
{ simpl. cut(ttq_ab M b a0 <= ttqb M b). lia. eapply IHM. }
{ simpl.  eapply IHM. }
{ simpl. cut(ttq_ab M b a0 <= ttqb M b). lia. eapply IHM. }
{ simpl. eapply IHM. }
Qed.

Lemma ttq_ab_delete (M:list fill_type)(b:Bid)(a:Ask)(m:fill_type):
In m M -> (b<>bid_of m)\/(a<>ask_of m) -> ttq_ab M b a = ttq_ab (delete m M) b a.
Proof.  revert a b m. induction M as [|m' M'].
{ simpl. intros. elim H. }
{ intros. destruct H0.
  { destruct H.
    { subst m'. simpl. destruct (b_eqb b (bid_of m)) eqn:Hbm.
      move /eqP in Hbm. subst b. elim H0. auto.
      destruct (a_eqb a (ask_of m)). simpl. replace (m_eqb m m) with true.
      auto. eauto. simpl. replace (m_eqb m m) with true. auto.
      eauto.
     }
     { simpl.
       destruct (a_eqb a (ask_of m') && b_eqb b (bid_of m')) eqn: Habm.
       destruct (m_eqb m m') eqn:Hmm. move /eqP in Hmm.
       subst m. move /andP in Habm.  destruct Habm.
       move /eqP in H2.  subst b.  elim H0.  auto.
       simpl. rewrite Habm.
        eapply IHM' with (a:=a)(b:=b) in H. lia.
        left.  auto.
       destruct (m_eqb m m') eqn:Hmm. auto. simpl.
        rewrite Habm.
        eapply IHM' with (a:=a)(b:=b) in H. lia.
        left.  auto.
      }
  }
  { destruct H.
    {
      subst m'. simpl. destruct (a_eqb a (ask_of m)) eqn:Hbm.
      move /eqP in Hbm. subst a. elim H0. auto.
      destruct (b_eqb b (bid_of m)). simpl. replace (m_eqb m m) with true.
      auto. eauto. simpl. replace (m_eqb m m) with true. auto.
      eauto.
     }
     { simpl.
       destruct (a_eqb a (ask_of m') && b_eqb b (bid_of m')) eqn: Habm.
       destruct (m_eqb m m') eqn:Hmm. move /eqP in Hmm.
       subst m. move /andP in Habm.  destruct Habm.
       move /eqP in H1.  subst a.  elim H0.  auto.
       simpl. rewrite Habm.
       eapply IHM' with (a:=a)(b:=b) in H. lia.
        right.  auto.
       destruct (m_eqb m m') eqn:Hmm. auto. simpl.
        rewrite Habm.
        eapply IHM' with (a:=a)(b:=b) in H. lia.
        right.  auto.

     }
  }
  }
  Qed.

Hint Resolve ttq_ab_le_ttqb ttq_ab_le_ttqa : core.

Lemma b_in_a_out_m_exists (M:list fill_type)(b:Bid)(a:Ask):
ttqa M a >= ttq_ab M b a ->
ttqb M b > ttq_ab M b a ->
exists m : fill_type,
  In m M /\ bid_of m = b /\ ask_of m <> a.
  Proof.
  {
    revert a b. induction M as [|m' M'].
    simpl. intros. lia.
    simpl. intros.
    destruct (a_eqb a (ask_of m')) eqn: Ham;
    destruct (b_eqb b (bid_of m')) eqn: Hbm.
    { simpl in H. simpl in H0.
      assert(Hm: exists m : fill_type,
      (In m M') /\ bid_of m = b /\ ask_of m <> a).
      apply IHM' with (a:=a)(b:=b). lia. lia.
      destruct Hm as [m0 Hm].
      exists m0. split. right. apply Hm. apply Hm.
    }
    {
     simpl in H. simpl in H0.
     assert(Hm: exists m : fill_type,
     (In m M') /\ bid_of m = b /\ ask_of m <> a).
     apply IHM' with (a:=a)(b:=b).
     assert (ttq_ab M' b a <= ttqa M' a). eauto. lia. lia.
     destruct Hm as [m0 Hm].
     exists m0. split. right. apply Hm. apply Hm.
    }
    {
    exists m'. split. left. auto. move /eqP in Ham.
    move /eqP in Hbm. auto.
    }
    {
     simpl in H. simpl in H0.
     assert(Hm: exists m : fill_type,
     (In m M') /\ bid_of m = b /\ ask_of m <> a).
     apply IHM' with (a:=a)(b:=b).
     lia. lia.
     destruct Hm as [m0 Hm].
     exists m0. split. right. apply Hm. apply Hm.
    }
  } Qed.

Lemma a_in_b_out_m_exists  (M:list fill_type)(b:Bid)(a:Ask):
ttqa M a > ttq_ab M b a ->
ttqb M b >= ttq_ab M b a ->
exists m : fill_type,
  In m M /\ ask_of m = a /\ bid_of m <> b.
  Proof.
  {
    revert a b. induction M as [|m' M'].
    simpl. intros. lia.
    simpl. intros.
    destruct (a_eqb a (ask_of m')) eqn: Ham;
    destruct (b_eqb b (bid_of m')) eqn: Hbm.
    { simpl in H. simpl in H0.
      assert(Hm: exists m : fill_type,
      (In m M') /\ ask_of m = a /\ bid_of m <> b).
      apply IHM' with (a:=a)(b:=b). lia. lia.
      destruct Hm as [m0 Hm].
      exists m0. split. right. apply Hm. apply Hm.
    }
    {
    exists m'. split. left. auto. move /eqP in Ham.
    move /eqP in Hbm. auto.
    }
    {
     simpl in H. simpl in H0.
     assert(Hm: exists m : fill_type,
     (In m M') /\ ask_of m = a /\ bid_of m <> b).
     apply IHM' with (a:=a)(b:=b). lia.
     assert (ttq_ab M' b a <= ttqb M' b). eauto. lia.
     destruct Hm as [m0 Hm].
     exists m0. split. right. apply Hm. apply Hm.
    }
    {
     simpl in H. simpl in H0.
     assert(Hm: exists m : fill_type,
     (In m M') /\ ask_of m = a /\ bid_of m <> b).
     apply IHM' with (a:=a)(b:=b).
     lia. lia.
     destruct Hm as [m0 Hm].
     exists m0. split. right. apply Hm. apply Hm.
    }
  } Qed.

Hint Resolve a_in_b_out_m_exists b_in_a_out_m_exists :core.
(*Total traded quanities of matching (list fill_type) *)

Fixpoint QM (M:list fill_type) :nat:=
match M with
|nil => 0
|m::M => tq m + QM M
end.

Lemma QM_elim0 (M:list fill_type) (m :fill_type):
In m M -> QM(M) >= (tq m).
Proof.  induction M. simpl. intros. elim H.
intros. simpl. destruct H. subst a. lia.
cut(QM M >= tq m). lia. apply IHM. auto. Qed.

Lemma QM_elim1 (M:list fill_type) (m :fill_type):
In m M -> QM(delete m M) =QM(M) - (tq m).
Proof.  induction M as [| m' M']. simpl. auto.
simpl. destruct (m_eqb m m') eqn:Hmm.
move /eqP in Hmm. subst m. lia.
simpl. intros.  move /eqP in Hmm.
destruct H. subst m. elim Hmm. auto.
rewrite IHM'. auto. assert(QM M' >= tq m).
apply QM_elim0. auto. lia. Qed.

Lemma QM_elim2 (M:list fill_type) (m1 m2:fill_type):
m1<>m2 -> In m1 M -> In m2 M -> QM M >= tq m1 + tq m2.
Proof.
induction M. simpl.
intros H0 H. elim H. intros.
destruct H0;destruct H1.
{
subst a. subst m1. elim H. auto.
}
{ simpl. subst a. cut(QM M >= tq m2). lia.
  apply QM_elim0. auto.
}
{
simpl. subst a. cut(QM M >= tq m1). lia.
  apply QM_elim0. auto.
}
{ simpl. cut(QM M >= tq m1 + tq m2). lia.
apply IHM. auto. auto. auto.
}
Qed.

Lemma QM_perm (M1 M2:list fill_type):
perm M1 M2 -> QM(M1) = QM(M2).
Proof. revert M2. induction M1.
intros. unfold perm in H.
move /andP in H. destruct H.
assert(M2=nil).
eauto. rewrite H1. auto.
intros. unfold perm in H.
move /andP in H. destruct H.
simpl. assert(In a M2). eauto.
assert(QM(delete a M2) =QM(M2) - (tq a)).
apply QM_elim1. auto.
apply included_elim3a with (a0:=a) in H.
simpl in H. replace (m_eqb a a) with true in H.
apply included_elim3a with (a0:=a) in H0.
simpl in H0. replace (m_eqb a a) with true in H0.
assert(perm M1 (delete a M2)).
unfold perm. apply /andP. auto.
apply IHM1 in H3.
apply QM_elim0 in H1. lia. eauto. eauto. Qed.

(*Sum of quantities of all the bids present in a list*)

Fixpoint QB (B:list Bid) :nat:=
match B with
|nil => 0
|b::B => bq b + QB B
end.

(*Sum of quantities of all the asks present in a list*)
Fixpoint QA (A:list Ask) :nat:=
match A with
|nil => 0
|a::A => sq a + QA A
end.

(*This function computes total traded quantity in a matching by computing total traded quantity of each ask. Note that QM and QMa are the same values and is being proved below *)
Fixpoint QMa (M:list fill_type)(A:list Ask):nat:=
match A with
|nil => 0
|a::A' => (ttqa M a) + QMa M A'
end.

(*This function computes total traded quantity in a matching by computing total traded quantity of each bid. Note that QM and QMb are the same values and is being proved below *)
Fixpoint QMb (M:list fill_type)(B:list Bid):nat:=
match B with
|nil => 0
|b::B' => (ttqb M b) + QMb M B'
end.

Lemma QMa_elim1 (M:list fill_type)(A:list Ask)(m:fill_type) (NDA:NoDup A):
~In (ask_of m) A-> QMa (m :: M) A = QMa M A.
Proof. revert m M. induction A as [|a A'].
intros. simpl. auto. intros. simpl. destruct (a_eqb a (ask_of m)) eqn: Ham.
move /eqP in Ham. subst a. elim H. auto.  cut(QMa (m :: M) A' = QMa M A'). lia.
eapply IHA'. eauto. eauto. Qed.

Lemma QMa_elim2 (M:list fill_type)(A:list Ask)(m:fill_type)(NDA:NoDup A):
In (ask_of m) A -> QMa (m :: M) A = tq m + QMa M (A).
Proof. revert m M. induction A as [|a A'].
{ simpl. intros. auto. }
{ intros. destruct (a_eqb a (ask_of m)) eqn: Ham. destruct H. simpl. rewrite Ham.
rewrite QMa_elim1. eauto. rewrite <-H. eauto. lia. move /eqP in Ham. rewrite <-Ham in H.
assert(~In a A'). eauto. auto. destruct H. move /eqP in Ham. subst a. auto.
 simpl. rewrite Ham. rewrite IHA'. eauto. eauto. lia. } Qed.

Lemma QMb_elim1 (M:list fill_type)(B:list Bid)(m:fill_type) (NDB:NoDup B):
~In (bid_of m) B-> QMb (m :: M) B = QMb M B.
Proof. revert m M. induction B as [|b B'].
intros. simpl. auto. intros. simpl. destruct (b_eqb b (bid_of m)) eqn: Hbm.
move /eqP in Hbm. subst b. elim H. auto.  cut(QMb (m :: M) B' = QMb M B'). lia.
eapply IHB'. eauto. eauto. Qed.

Lemma QMb_elim2 (M:list fill_type)(B:list Bid)(m:fill_type)(NDB:NoDup B):
In (bid_of m) B -> QMb (m :: M) B = tq m + QMb M (B).
Proof. revert m M. induction B as [|b B'].
{ simpl. intros. auto. }
{ intros. destruct (b_eqb b (bid_of m)) eqn: Hbm. destruct H. simpl. rewrite Hbm.
rewrite QMb_elim1. eauto. rewrite <-H. eauto. lia. move /eqP in Hbm. rewrite <-Hbm in H.
assert(~In b B'). eauto. auto. destruct H. move /eqP in Hbm. subst b. auto.
 simpl. rewrite Hbm. rewrite IHB'. eauto. eauto. lia. } Qed.

Hint Resolve QMb_elim1 QMb_elim2 QMa_elim1 QMb_elim2: core.

Lemma QM_equal_QMa (M:list fill_type)(A:list Ask) (NDA:NoDup A):
asks_of M [<=] A -> QMa M A = QM(M).
Proof. {
revert A NDA. induction M as [|m M'].
 { simpl. induction A. simpl. auto. simpl. intros. apply IHA.
eauto. eauto. }
 { induction A as [|a A'].
   { simpl. intros. assert(In (ask_of m) nil). eauto. inversion H0. }
   { intros. destruct (a_eqb a (ask_of m)) eqn:Ham.
                    { simpl. rewrite Ham. move /eqP in Ham. assert (asks_of M' [<=] a :: A').
                    eauto. eapply IHM' in H0. rewrite<- H0. simpl.
                    cut(QMa (m :: M') A' = QMa M' A'). lia. eapply QMa_elim1. eauto.
                    rewrite<- Ham. eauto. eauto. }
                    { (*Prove more properties of QMa for different scenerios*)
                    assert(In a (asks_of M')\/~In a (asks_of M')).
                    eauto. destruct H0.
                             2:{ simpl. rewrite Ham. eapply ttqa_elim in H0 as H1.
                             rewrite H1.
                             rewrite IHA'. eauto. simpl in H. eapply subset_elim3 in H.
                              all:auto. move /eqP in Ham;auto. }
                             { cut(QMa M' (a :: A') = QM(M')).
                              assert(QMa (m :: M') (a::A') = tq m + QMa M' (a::A')).
                              eapply QMa_elim2 with (A:=(a::A'))(M:=M')(m:=m).
                              eauto. simpl. right;auto. simpl in H.
                              assert(In (ask_of m) (a::A')). eauto. destruct H1.
                              subst a. move /eqP in Ham. elim Ham. auto. auto.
                              rewrite H1. simpl. lia.
                             specialize (IHM' (a::A')). eapply IHM'. eauto. eauto. }}}}}
                             Qed.

Lemma QMa_equal_QMa (M1 M2:list fill_type)(A:list Ask):
(forall a, ttqa M1 a = ttqa M2 a) -> QMa M1 A = QMa M2 A.
Proof. induction A. simpl;auto.
simpl. intro H.  specialize (H a) as Ha. rewrite Ha. rewrite IHA.
auto. auto. Qed.

Lemma QM_equal_QMb (M:list fill_type)(B:list Bid) (NDB:NoDup B):
bids_of M [<=] B -> QMb M B = QM(M).
Proof. {
revert B NDB. induction M as [|m M'].
 { simpl. induction B. simpl. auto. simpl. intros. apply IHB.
eauto. eauto. }
 { induction B as [|b B'].
   { simpl. intros. assert(In (bid_of m) nil). eauto. inversion H0. }
   { intros. destruct (b_eqb b (bid_of m)) eqn:Hbm.
                    { simpl. rewrite Hbm. move /eqP in Hbm. assert (bids_of M' [<=] b :: B').
                    eauto. eapply IHM' in H0. rewrite<- H0. simpl.
                    cut(QMb (m :: M') B' = QMb M' B'). lia. eapply QMb_elim1. eauto.
                    rewrite<- Hbm. eauto. eauto. }
                    assert(In b (bids_of M')\/~In b (bids_of M')).
                    eauto. destruct H0.
                             2:{ simpl. rewrite Hbm. eapply ttqb_elim in H0 as H1.
                             rewrite H1.
                             rewrite IHB'. eauto. simpl in H. eapply subset_elim3 in H.
                              all:auto. move /eqP in Hbm;auto. }
                             { cut(QMb M' (b :: B') = QM(M')).
                              assert(QMb (m :: M') (b::B') = tq m + QMb M' (b::B')).
                              eapply QMb_elim2 with (B:=(b::B'))(M:=M')(m:=m).
                              eauto. simpl. right;auto. simpl in H.
                              assert(In (bid_of m) (b::B')). eauto. destruct H1.
                              subst b. move /eqP in Hbm. elim Hbm. auto. auto.
                              rewrite H1. simpl. lia.
                             specialize (IHM' (b::B')). eapply IHM'. eauto. eauto. }}}}
                             Qed.

Lemma QMb_equal_QMb (M1 M2:list fill_type)(B:list Bid):
(forall b, ttqb M1 b = ttqb M2 b) -> QMb M1 B = QMb M2 B.
Proof. induction B as [| b B]. simpl;auto.
simpl. intro H.  specialize (H b) as Hb. rewrite Hb. rewrite IHB.
auto. auto. Qed.

Lemma ttqb_BM_t_B (M:list fill_type)(B:list Bid)(NDB:NoDup B) :
(bids_of M [<=] B)  ->
(forall b, In b (bids_of M) -> ttqb M b <= bq b) ->(forall b, In b B -> ttqb M b <= bq b).
Proof. intros. assert(Hb: In b (bids_of M) \/~In b (bids_of M)). eauto.
destruct Hb. apply H0. auto. apply ttqb_elim in H2. lia. Qed.

Lemma fill_size_vs_bid_size (M:list fill_type)(B:list Bid)(NDB:NoDup B):
(forall b, In b B -> ttqb M b <= bq b) -> QMb M B <=QB(B).
Proof. revert M. induction B as [|b B'].
{ intros. simpl. auto. }
{ intros. simpl. assert(H0: ttqb M b <= bq b).  eapply H with (b0:=b). auto.
  cut(QMb M B' <= QB B'). lia.  eapply IHB'. eauto. auto. } Qed.

Lemma ttqaM1_equal_ttqaM2 (M1 M2:list fill_type)(A:list Ask)(NDA: NoDup A):
asks_of M1 [<=] A -> asks_of M2 [<=] A -> (forall a, ttqa M1 a = ttqa M2 a) -> QM M1 = QM M2.
Proof. intros. eapply QM_equal_QMa in H;eapply QM_equal_QMa in H0.
eapply QMa_equal_QMa with (A:=A) in H1. lia. all:exact. Qed.

Lemma ttqa_AM_t_A (M:list fill_type)(A:list Ask)(NDA:NoDup A) :
(asks_of M [<=] A)  ->
(forall a, In a (asks_of M) -> ttqa M a <= sq a) ->(forall a, In a A -> ttqa M a <= sq a).
Proof. intros. assert(Ha: In a (asks_of M) \/~In a (asks_of M)). eauto.
destruct Ha. apply H0. auto. apply ttqa_elim in H2. lia. Qed.

Lemma fill_size_vs_ask_size (M:list fill_type)(A:list Ask)(NDA:NoDup A):
(forall a, In a A -> ttqa M a <= sq a) -> QMa M A <=QA(A).
Proof. revert M. induction A as [|a A'].
{ intros. simpl. auto. }
{ intros. simpl. assert(H0: ttqa M a <= sq a).  eapply H with (a0:=a). auto.
  cut(QMa M A' <= QA A'). lia.  eapply IHA'. eauto. auto. } Qed.

Lemma ttqbM1_equal_ttqbM2 (M1 M2:list fill_type)(B:list Bid)(NDB: NoDup B):
bids_of M1 [<=] B -> bids_of M2 [<=] B -> (forall b, ttqb M1 b = ttqb M2 b) -> QM M1 = QM M2.
Proof. intros. eapply QM_equal_QMb in H;eapply QM_equal_QMb in H0.
eapply QMb_equal_QMb with (B:=B) in H1. lia. all:exact. Qed.

Hint Resolve
QM_equal_QMa QMa_equal_QMa QM_equal_QMb QMb_equal_QMb
 fill_size_vs_bid_size ttqaM1_equal_ttqaM2 ttqb_BM_t_B ttqa_AM_t_A
  fill_size_vs_ask_size ttqbM1_equal_ttqbM2: core.

End quantity.

Hint Immediate ttqa_intro_ab ttqa_intro_ba: core.
Hint Immediate ttqb_elim ttqa_elim: core.
Hint Resolve a_in_b_out_m_exists b_in_a_out_m_exists :core.
Hint Immediate ttqb_BM_t_B ttqa_AM_t_A : core.
Hint Resolve ttqb_intro ttqa_intro : core.
Hint Resolve QM_elim0 QM_elim1 QM_perm : core.
Hint Resolve ttq_ab_elim_b ttq_ab_elim_a : core.
Hint Resolve ttq_ab_le_ttqb ttq_ab_le_ttqa : core.
Hint Resolve QM_equal_QMa QMa_equal_QMa QM_equal_QMb QMb_equal_QMb
 fill_size_vs_bid_size ttqaM1_equal_ttqaM2
  fill_size_vs_ask_size ttqbM1_equal_ttqbM2: core.
Hint Resolve ttqb_delete_m_not_ofb ttqb_delete_m_ofb : core.
Hint Resolve ttqa_delete_m_not_ofa ttqa_delete_m_ofa : core.


(* ---------------------------------------------------------------------
   This file contains definitions and proof scripts related to
   (i) closure operations for context-free grammars,
   (ii) context-free grammars simplification
   (iii) context-free grammar Chomsky normalization and
   (iv) pumping lemma for context-free languages.

   More information can be found in the paper "Formalization of the
   Pumping Lemma for Context-Free Languages", submitted to JFR.

   Marcus Vinícius Midena Ramos
   mvmramos@gmail.com
   --------------------------------------------------------------------- *)

(* --------------------------------------------------------------------- *)
(* BASIC LEMMAS                                                          *)
(* --------------------------------------------------------------------- *)

Require Import Ring.
Require Import Omega.
Require Import NPeano.
Require Import Even.
Require Import NZPow.

Lemma lep1m2_ltp1:
forall i x: nat, i <= x + 1 - 2 -> i < x + 1.
Proof.
intros i x H.
omega.
Qed.

Lemma lep1m2_lt:
forall i x: nat, x > 0 -> i <= x + 1 - 2 -> i < x.
Proof.
intros i x H1 H2.
omega.
Qed.

Lemma gt_any_gt_0:
forall i j: nat,
i > j -> i > 0.
Proof.
intros i j H.
destruct i.
- apply lt_n_0 in H.
  contradiction.
- apply gt_Sn_O.
Qed.

Lemma lt_1_eq_0:
forall i: nat,
i < 1 -> i = 0.
Proof.
intros i H.
destruct i.
- reflexivity.
- apply lt_S_n in H.
  apply lt_n_0 in H.
  contradiction.
Qed.

Lemma n_minus_1:
forall n: nat,
n <> 0 -> n-1 < n.
Proof.
intros n H.
destruct n.
- omega.
- omega.
Qed.

Lemma gt_zero_exists:
forall i: nat,
i > 0 ->
exists j: nat, i = S j.
Proof.
intros i H.
destruct i.
- omega.
- exists i.
  reflexivity.
Qed.

Lemma max_n_n:
forall n: nat,
max n n = n.
Proof.
induction n.
- simpl.
  reflexivity.
- simpl.
  rewrite IHn.
  reflexivity.
Qed.

Lemma max_n_0:
forall n: nat,
max n 0 = n.
Proof.
destruct n.
- simpl.
  reflexivity.
- simpl.
  reflexivity.
Qed.

Definition injective (A B: Type) (f: A -> B): Prop:=
forall e1 e2: A,
f e1 = f e2 -> e1 = e2.

Lemma odd_1:
odd 1.
Proof.
apply odd_S.
apply even_O.
Qed.

Lemma pow_le:
forall n n1 n2: nat,
n > 0 ->
n1 <= n2 ->
n ^ n1 <= n ^ n2.
Proof.
intros n n1 n2 H1 H2.
apply Nat.pow_le_mono_r.
- omega.
- exact H2.
Qed.

Lemma pow_lt:
forall n n1 n2: nat,
n > 1 ->
n1 < n2 ->
n ^ n1 < n ^ n2.
Proof.
intros n n1 n2 H1 H2.
apply Nat.pow_lt_mono_r.
- exact H1.
- exact H2.
Qed.

Lemma nat_struct:
forall n: nat,
n = 0 \/ exists n': nat, n = S n'.
destruct n.
- left.
  reflexivity.
- right.
  exists n.
  reflexivity.
Qed.

Lemma sum_double:
forall n: nat,
n + n = 2 * n.
Proof.
induction n.
- simpl.
  reflexivity.
- rewrite plus_Sn_m.
  rewrite plus_comm.
  rewrite plus_Sn_m.
  rewrite IHn.
  simpl.
  repeat rewrite plus_0_r.
  symmetry.
  rewrite plus_comm.
  rewrite plus_Sn_m.
  reflexivity.
Qed.

Lemma add_exp:
forall n: nat,
n >= 1 -> 2 * 2 ^ (n - 1) = 2 ^ n.
Proof.
destruct n.
- intros H.
  omega.
- intros H.
  assert (H1: n = 0 \/ n >= 1) by omega.
  destruct H1 as [H1 | H1].
  + subst.
    simpl.
    reflexivity.
  + simpl.
    rewrite <- minus_n_O.
    rewrite <- plus_n_O.
    reflexivity.
Qed.

Lemma ge_exists:
forall x y: nat,
x >= y ->
exists z: nat,
x = z + y.
Proof.
induction y.
- intros H.
  exists x.
  rewrite plus_0_r.
  reflexivity.
- intros H.
  assert (H1: x >= y) by omega.
  specialize (IHy H1).
  destruct IHy as [z IHy].
  rewrite IHy.
  exists (z - 1).
  assert (H2: z >= 1) by omega.
  omega.
Qed.

Lemma pow_2_gt_0:
forall n: nat,
2 ^ n > 0.
Proof.
induction n.
- simpl.
  omega.
- simpl.
  omega.
Qed.