Lecture notes 20210317 Denotational Semantics 3

Remark. Some material in this lecture is from << Software Foundation >> volume 1 and volume 2.
Require Import PL.Imp.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Classes.Morphisms.

Review: Programs' Denotation

In the last lecture, we learnt to define expressions' denotations. Specifically, an integer expression's denotation is a function from program states to integers, and a boolean expression's denotation is a subset of program states. Sometimes, we will also write [[ ]] to describe expression denotation. For example, our definition of aeval and beval partly say:
    - [a1 + a2 ]] = [a1 ]] + [a2 ]]

    - [a1 - a2 ]] = [a1 ]] - [a2 ]]

    - [a1 * a2 ]] = [a1 ]] * [a2 ]]

    - [b1 && b2 ]] = the intersection of [b1 ]and [b2 ]]

    - [[ ! b ]] = the complement of [b ]].
    
For programs, we use binary relations between program states to represent their denotations.
Module CEval_first_try.

Definition if_sem
  (b: bexp)
  (then_branch else_branch: state -> state -> Prop)
  : state -> state -> Prop
:=
  BinRel.union
    (BinRel.concat (BinRel.test_rel (beval b)) then_branch)
    (BinRel.concat (BinRel.test_rel (beval (BNot b))) else_branch).
Soppose then_branch and else_branch are denotations of the then-branch and else-branch of an if-command. Here, the first clause of union the set of program state pairs (st1, st2) such that:
  • (st1, st2) belongs to then_branch and b is true on st1
And similarly, the second clause of union the set of program state pairs (st1, st2) such that:
  • (st1, st2) belongs to else_branch and b is false on st1
The union of them is the semantics of an if-command.
Fixpoint ceval (c: com): state -> state -> Prop :=
  match c with
  | CSkipBinRel.id
  | CAss X E
      fun st1 st2
        st2 X = aeval E st1
        Y, XY -> st1 Y = st2 Y
  | CSeq c1 c2BinRel.concat (ceval c1) (ceval c2)
  | CIf b c1 c2if_sem b (ceval c1) (ceval c2)
  | CWhile _ _BinRel.empty
  end.
Here, a pair (st1, st2) is inside the denotation of c if and only if ceval c st1 st2 holds. The following notation and lemmas may help you understand.
Notation "'The_pair_(' st1 , st2 ')_is_in_[[' c ]]" := (ceval c st1 st2) (at level 45, no associativity).

Lemma ceval_skip: st1 st2,
  The_pair_( st1 , st2 )_is_in_[[ Skip ]] ↔
  st1 = st2.
Proof.
  intros.
  simpl.
  unfold id.
  tauto.
Qed.

Lemma ceval_seq: st1 st3 c1 c2,
  The_pair_( st1 , st3 )_is_in_[[ c1;; c2 ]] ↔
  st2,
    The_pair_( st1 , st2 )_is_in_[[ c1 ]] ∧
    The_pair_( st2 , st3 )_is_in_[[ c2 ]].
Proof.
  intros.
  simpl.
  unfold concat.
  tauto.
Qed.

Lemma ceval_if: st1 st2 b c1 c2,
  The_pair_( st1 , st2 )_is_in_[[ If b Then c1 Else c2 EndIf ]] ↔
  The_pair_( st1 , st2 )_is_in_[[ c1 ]] ∧ beval b st1
  The_pair_( st1 , st2 )_is_in_[[ c2 ]] ∧ ¬beval b st1.
Proof.
  intros.
  simpl.
  unfold if_sem.
  unfold iff, BinRel.union, BinRel.concat, BinRel.test_rel;
  split; simpl.
  + intros.
    destruct H as [[st1' [[? ?] ?]] | [st1' [[? ?] ?]]].
    - left.
      rewrite <- H in H1; tauto.
    - right.
      rewrite <- H in H1; tauto.
  + intros.
    destruct H as [[? ?] | [? ?]].
    - left.
      st1.
      tauto.
    - right.
      st1.
      tauto.
Qed.

End CEval_first_try.

Loops' Denotations

Loops' semantics is comparatively nontrivial. One understanding is: While b Do c EndWhile will test b first then either do Skip or execute c ;; While b Do c EndWhile. Another understanding is: a loop means executing the loop body zero time, one time, two times, or etc.
The first understanding is kind of self-defined. We choose the second one. The following recursive function defines the semantics of executing the loop body for exactly n times. In Coq, nat represents nature numbers. Coq users can write functions recursively on nature numbers. Specifically, a natural number n is either zero O (the "O" of Omega) or the successor of another natural number n', written as S n'.
Fixpoint iter_loop_body (b: bexp)
                        (loop_body: state -> state -> Prop)
                        (n: nat): state -> state -> Prop :=
  match n with
  | O
         BinRel.test_rel (beval (BNot b))
  | S n'
         BinRel.concat
           (BinRel.test_rel (beval b))
           (BinRel.concat
              loop_body
              (iter_loop_body b loop_body n'))
  end.
In short, iter_loop_body b loop_body n is defined as:
  • if n = 0, identity relation with the restriction that b is not true;
  • if n = n' + 1, first do loop_body then do iter_loop_body b loop_body n' with the restriction that b is true at beginning.
The union of these binary relations is exactly the meaning of while loops. The following relation operator omega_union defines the union of countably many relations.
Module DefinitionOfOmegaUnion.
Module BinRel.

Definition omega_union {A B} (rs: nat -> A -> B -> Prop): A -> B -> Prop :=
  fun st1 st2n, rs n st1 st2.

End BinRel.
End DefinitionOfOmegaUnion.
Import DefinitionOfOmegaUnion.

Definition loop_sem (b: bexp) (loop_body: state -> state -> Prop):
  state -> state -> Prop :=
  BinRel.omega_union (iter_loop_body b loop_body).
With loop_sem which is just defined, we are eventually ready to complete our definition of ceval.
Definition if_sem
  (b: bexp)
  (then_branch else_branch: state -> state -> Prop)
  : state -> state -> Prop
:=
  BinRel.union
    (BinRel.concat (BinRel.test_rel (beval b)) then_branch)
    (BinRel.concat (BinRel.test_rel (beval (BNot b))) else_branch).

Fixpoint ceval (c: com): state -> state -> Prop :=
  match c with
  | CSkipBinRel.id
  | CAss X E
      fun st1 st2
        st2 X = aeval E st1
        Y, XY -> st1 Y = st2 Y
  | CSeq c1 c2BinRel.concat (ceval c1) (ceval c2)
  | CIf b c1 c2if_sem b (ceval c1) (ceval c2)
  | CWhile b cloop_sem b (ceval c)
  end.

Notation "'The_pair_(' st1 , st2 ')_is_in_[[' c ]]" :=
  (ceval c%imp st1 st2) (at level 45, no associativity, c at level 0).
The following five lemmas are only presented for Coq proofs' convenience.
Lemma ceval_CSkip: ceval CSkip = BinRel.id.
Proof. intros. simpl. reflexivity. Qed.

Lemma ceval_CAss: X E,
  ceval (CAss X E) =
    fun st1 st2
      st2 X = aeval E st1
        Y, XY -> st1 Y = st2 Y.
Proof. intros. simpl. reflexivity. Qed.

Lemma ceval_CSeq: c1 c2,
  ceval (c1 ;; c2) = BinRel.concat (ceval c1) (ceval c2).
Proof. intros. simpl. reflexivity. Qed.

Lemma ceval_CIf: b c1 c2,
  ceval (CIf b c1 c2) = if_sem b (ceval c1) (ceval c2).
Proof. intros. simpl. reflexivity. Qed.

Lemma ceval_CWhile: b c,
  ceval (While b Do c EndWhile) = loop_sem b (ceval c).
Proof. intros. simpl. reflexivity. Qed.

Application Of Denotational Semantics

Will this program terminate?
    While true Do X ::= X + 1 EndWhile
No.
Module Example1.

Module DenotationalSemanticsApproach.
Import Abstract_Pretty_Printing.
Arguments ceval: simpl never.

Fact not_terminating: (X: var) (st: state), ¬st',
  The_pair_( st , st' )_is_in_[[ While true Do X ::= X + 1 EndWhile ]].
Proof.
  intros.
  pose proof
    classic
      (st',
         The_pair_( st , st' )_is_in_[[ While true Do X ::= X + 1 EndWhile ]]).
  destruct H; [| exact H].
  destruct H as [st' ?].
  assert (False); [| contradiction].
  rewrite ceval_CWhile in H.
  unfold loop_sem in H.
  unfold BinRel.omega_union in H.
  destruct H as [n H].
  revert st st' H; induction n; intros.
  + simpl in H.
    unfold BinRel.test_rel, Sets.complement, Sets.full in H.
    tauto.
  + simpl in H.
    unfold BinRel.concat at 1 in H.
    destruct H as [st0 [_ ?]].
    unfold concat in H.
    destruct H as [st1 [_ ?]].
    apply IHn in H.
    tauto.
Qed.

End DenotationalSemanticsApproach.

Module HoareLogicApproach.
Import Assertion_S_Tac.
Import Concrete_Pretty_Printing.
Import Axiomatic_semantics.
Import Derived_Rules.

Local Instance X: var := new_var().

Fact not_terminating:  {{ True }While true Do X ::= X + 1 EndWhile  {{ False }} .
Proof.
  eapply hoare_consequence_post.
  + apply hoare_while.
    apply hoare_asgn_conseq.
    assert_subst.
    assert_simpl.
    entailer.
    intros.
    exact I.
  + entailer.
    tauto.
Qed.

End HoareLogicApproach.

End Example1.
Will this program terminate?
    X ::= 2;;
    While 0 ≤ X Do X ::= X - 1 EndWhile
Yes.
This time, the only formal description we can use is via denotational semantics and we can prove it the following statement in Coq.
Fact terminating(Xvarstst',
  The_pair_st , st' )_is_in_[X ::= 2;;
                               While 1 ≤ X Do X ::= X - 1 EndWhile ]].
You can read its Coq proof after class.

Additional Readings

This time, we need to do constructive reasoning, i.e. construct an ending state from the beginning state.
Definition state_update (st: state) (X: var) (v: Z): state :=
  fun Yif (Nat.eq_dec X Y) then v else st Y.
Here, we define a program state, i.e. a new function from program variables to integers. This program state is almost the same as st but only differs with st on X's value. X's new value will be v.
The Coq expression if (Nat.eq_dec X Y) then _ else _ says, if X and Y are the same variable, do the calculation described by then; otherwise do the calculation defined by else. In proofs, we can write destruct (Nat.eq_dec X Y) to do case analysis on whether X and Y are the same variable.
It is worth one more sentence emphasizing that Nat.eq_dec X Y is not to tell whether their values are the same; it tells whether they are the same variable.
You might be curious why Nat appears here. Here is some explanation. You do not need understand all of this. You can freely skip it if you want.
If you take a look at how "variables" are formalized in Imp, you would find that they are just names! And different variables are just represented by different natural numbers, i.e. 1st variable, 2nd variable, etc. That is why to determine whether two variable names are the same is to determine whether two natural numbers are the same.
Lemma state_update_same: st X v,
  (state_update st X v) X = v.
Proof.
  intros.
  unfold state_update.
  destruct (Nat.eq_dec X X).
  + reflexivity.
  + assert (X = X). { reflexivity. }
    contradiction.
Qed.

Lemma state_update_diff: st X v,
  (Y, XY -> st Y = (state_update st X v) Y).
Proof.
  intros.
  unfold state_update.
  destruct (Nat.eq_dec X Y).
  - tauto.
  - reflexivity.
Qed.

Lemma state_update_spec: st X v,
  (state_update st X v) X = v
  (Y, XY -> st Y = (state_update st X v) Y).
Proof.
  intros.
  split; [apply state_update_same | apply state_update_diff].
Qed.

Module Example2.

Import Abstract_Pretty_Printing.

Arguments ceval: simpl never.

Fact terminating: (X: var) st, st',
  The_pair_( st , st' )_is_in_[[ X ::= 2;;
                                 While 1 ≤ X Do X ::= X - 1 EndWhile ]].
Proof.
  intros.
  (state_update st X 0).
  rewrite ceval_CSeq.
  unfold concat.
  (state_update st X 2).
  split.
  + rewrite ceval_CAss.
    apply state_update_spec.
  + rewrite ceval_CWhile.
    unfold loop_sem, BinRel.omega_union.
    2%nat.
    simpl.
    unfold BinRel.concat at 1.
    (state_update st X 2).
    split.
    {
      unfold BinRel.test_rel.
      split; [reflexivity |].
      unfold Func.test_le, constant_func, query_var.
      rewrite state_update_same.
      lia.
    }
    unfold BinRel.concat at 1.
    (state_update st X 1).
    split.
    {
      rewrite ceval_CAss.
      split.
      + rewrite state_update_same.
        simpl.
        unfold Func.sub, query_var, constant_func.
        rewrite state_update_same.
        lia.
      + intros.
        rewrite <- ! state_update_diff by exact H.
        reflexivity.
    }
    unfold BinRel.concat at 1.
    (state_update st X 1).
    split.
    {
      unfold BinRel.test_rel.
      split; [reflexivity |].
      unfold Func.test_le, constant_func, query_var.
      rewrite state_update_same.
      lia.
    }
    unfold BinRel.concat at 1.
    (state_update st X 0).
    split.
    {
      rewrite ceval_CAss.
      split.
      + rewrite state_update_same.
        simpl.
        unfold Func.sub, query_var, constant_func.
        rewrite state_update_same.
        lia.
      + intros.
        rewrite <- ! state_update_diff by exact H.
        reflexivity.
    }
    {
      unfold BinRel.test_rel.
      split; [reflexivity |].
      unfold Sets.complement, Func.test_le, constant_func, query_var.
      rewrite state_update_same.
      lia.
    }
Qed.

End Example2.

Semantic Equivalence

An Equivalence Between Integer Expressions

One week ago, we have defined semantic equivalence between integer expressions by:
  • Two expressions a1 and a2 are equivalent if evaluating them on st has the same result for every program state st.
Now, using higher-order understanding, we can restate it as follows:
  • Two expressions a1 and a2 are equivalent if their denotations are equivalent functions.
Formally:
Definition aexp_equiv (a1 a2: aexp): Prop :=
  Func.equiv (aeval a1) (aeval a2).
It is a equivalence relation.
Lemma aexp_equiv_refl: Reflexive aexp_equiv.
Proof.
  unfold Reflexive, aexp_equiv.
  intros.
  reflexivity.
Qed.

Lemma aexp_equiv_sym: Symmetric aexp_equiv.
Proof.
  unfold Symmetric, aexp_equiv.
  intros.
  rewrite H.
  reflexivity.
Qed.

Lemma aexp_equiv_trans: Transitive aexp_equiv.
Proof.
  unfold Transitive, aexp_equiv.
  intros.
  rewrite H, H0.
  reflexivity.
Qed.
Moreover, it is a congruence (同余关系). That is, the equivalence of two subexpressions implies the equivalence of the larger expressions in which they are embedded.
The main idea is that the congruence property allows us to replace a small part of a large expression with an equivalent small part and know that the whole large expressions are equivalent without doing an explicit proof about the non-varying parts — i.e., the "proof burden" of a small change to a large expression is proportional to the size of the change, not the expression.
Lemma APlus_congr:
  Proper (aexp_equiv ==> aexp_equiv ==> aexp_equiv) APlus.
Proof.
  unfold Proper, respectful.
  unfold aexp_equiv.
  intros a1 a1' ? a2 a2' ?.
  simpl.
  rewrite H, H0.
  reflexivity.
Qed.

Lemma AMinus_congr:
  Proper (aexp_equiv ==> aexp_equiv ==> aexp_equiv) AMinus.
Proof.
  unfold Proper, respectful.
  unfold aexp_equiv.
  intros a1 a1' ? a2 a2' ?.
  simpl.
  rewrite H, H0.
  reflexivity.
Qed.

Lemma AMult_congr:
  Proper (aexp_equiv ==> aexp_equiv ==> aexp_equiv) AMult.
Proof.
  unfold Proper, respectful.
  unfold aexp_equiv.
  intros a1 a1' ? a2 a2' ?.
  simpl.
  rewrite H, H0.
  reflexivity.
Qed.

Existing Instances aexp_equiv_refl
                   aexp_equiv_sym
                   aexp_equiv_trans
                   APlus_congr
                   AMinus_congr
                   AMult_congr.

An Equivalence Between Boolean Expressions

Then we will establish the theory of boolean expression's equivalence.
Definition bexp_equiv (b1 b2: bexp): Prop :=
  Sets.equiv (beval b1) (beval b2).
We need the following auxiliary lemmas.

Lemma Sets_equiv_refl: A, Reflexive (@Sets.equiv A).
Proof.
  unfold Reflexive, Sets.equiv.
  intros.
  reflexivity.
Qed.

Lemma Sets_equiv_sym: A, Symmetric (@Sets.equiv A).
Proof.
  unfold Symmetric, Sets.equiv.
  intros.
  rewrite H.
  reflexivity.
Qed.

Lemma Sets_equiv_trans: A, Transitive (@Sets.equiv A).
Proof.
  unfold Transitive, Sets.equiv.
  intros.
  rewrite H, H0.
  reflexivity.
Qed.

Lemma Func_test_eq_equiv: A,
  Proper (@Func.equiv A ==> @Func.equiv A ==> @Sets.equiv A) Func.test_eq.
Proof.
  unfold Proper, respectful.
  unfold Func.equiv, Sets.equiv, Func.test_eq.
  intros A f1 f2 ? g1 g2 ?.
  intros.
  rewrite H, H0.
  reflexivity.
Qed.

Lemma Func_test_le_equiv: A,
  Proper (@Func.equiv A ==> @Func.equiv A ==> @Sets.equiv A) Func.test_le.
Proof.
  unfold Proper, respectful.
  unfold Func.equiv, Sets.equiv, Func.test_le.
  intros A f1 f2 ? g1 g2 ?.
  intros.
  rewrite H, H0.
  reflexivity.
Qed.

Lemma Sets_intersect_equiv: A,
  Proper (@Sets.equiv A ==> @Sets.equiv A ==> @Sets.equiv A) Sets.intersect.
Proof.
  unfold Proper, respectful.
  unfold Sets.equiv, Sets.intersect.
  intros A S1 S2 ? T1 T2 ?.
  intros.
  rewrite H, H0.
  reflexivity.
Qed.

Lemma Sets_complement_equiv: A,
  Proper (@Sets.equiv A ==> @Sets.equiv A) Sets.complement.
Proof.
  unfold Proper, respectful.
  unfold Sets.equiv, Sets.complement.
  intros A S1 S2 ?.
  intros.
  rewrite H.
  reflexivity.
Qed.

Lemma Sets_complement_complement: A (S: A -> Prop),
  Sets.equiv (Sets.complement (Sets.complement S)) S.
Proof.
  intros.
  unfold Sets.equiv, Sets.complement.
  intros.
  tauto.
Qed.

Existing Instances Sets_equiv_refl
                   Sets_equiv_sym
                   Sets_equiv_trans
                   Func_test_eq_equiv
                   Func_test_le_equiv
                   Sets_intersect_equiv
                   Sets_complement_equiv.
Similar to integer expressions' equivalence, boolean expressions' equivalence is also an equivalence relation and a congruence relation.
Lemma bexp_equiv_refl: Reflexive bexp_equiv.
Proof.
  unfold Reflexive, bexp_equiv.
  intros.
  reflexivity.
Qed.

Lemma bexp_equiv_sym: Symmetric bexp_equiv.
Proof.
  unfold Symmetric, bexp_equiv.
  intros.
  rewrite H.
  reflexivity.
Qed.

Lemma bexp_equiv_trans: Transitive bexp_equiv.
Proof.
  unfold Transitive, bexp_equiv.
  intros.
  rewrite H, H0.
  reflexivity.
Qed.

Lemma BEq_congr:
  Proper (aexp_equiv ==> aexp_equiv ==> bexp_equiv) BEq.
Proof.
  unfold Proper, respectful.
  unfold aexp_equiv, bexp_equiv.
  intros; simpl.
  rewrite H, H0.
  reflexivity.
Qed.

Lemma BLe_congr:
  Proper (aexp_equiv ==> aexp_equiv ==> bexp_equiv) BLe.
Proof.
  unfold Proper, respectful.
  unfold aexp_equiv, bexp_equiv.
  intros; simpl.
  rewrite H, H0.
  reflexivity.
Qed.

Lemma BAnd_congr:
  Proper (bexp_equiv ==> bexp_equiv ==> bexp_equiv) BAnd.
Proof.
  unfold Proper, respectful.
  unfold bexp_equiv.
  intros; simpl.
  rewrite H, H0.
  reflexivity.
Qed.

Lemma BNot_congr: Proper (bexp_equiv ==> bexp_equiv) BNot.
Proof.
  unfold Proper, respectful.
  unfold bexp_equiv.
  intros; simpl.
  rewrite H.
  reflexivity.
Qed.

Existing Instances bexp_equiv_refl
                   bexp_equiv_sym
                   bexp_equiv_trans
                   BEq_congr
                   BLe_congr
                   BAnd_congr
                   BNot_congr.

An Equivalence Between Programs

For program equivalence, we need to define equivalence between relations first.
Module BinRel.

Definition equiv {A B: Type} (r1 r2: A -> B -> Prop): Prop :=
  a b, r1 a br2 a b.

Definition le {A B: Type} (r1 r2: A -> B -> Prop): Prop :=
  a b, r1 a b -> r2 a b.

End BinRel.
Here is its properties.
Lemma Rel_equiv_refl: A B, Reflexive (@BinRel.equiv A B).
Proof.
  unfold Reflexive, BinRel.equiv.
  intros.
  reflexivity.
Qed.

Lemma Rel_equiv_sym: A B, Symmetric (@BinRel.equiv A B).
Proof.
  unfold Symmetric, BinRel.equiv.
  intros.
  rewrite H.
  reflexivity.
Qed.

Lemma Rel_equiv_trans: A B, Transitive (@BinRel.equiv A B).
Proof.
  unfold Transitive, BinRel.equiv.
  intros.
  rewrite H, H0.
  reflexivity.
Qed.

Lemma Rel_equiv_test_rel: A,
  Proper (@Sets.equiv A ==> @BinRel.equiv A A) BinRel.test_rel.
Proof.
  unfold Proper, respectful.
  unfold Sets.equiv, BinRel.equiv, BinRel.test_rel.
  intros A X Y ?.
  intros.
  rewrite H.
  reflexivity.
Qed.

Lemma Rel_equiv_concat: A,
  Proper (@BinRel.equiv A A ==> @BinRel.equiv A A ==> @BinRel.equiv A A)
    BinRel.concat.
Proof.
  unfold Proper, respectful.
  unfold BinRel.equiv, BinRel.concat.
  intros A X1 X2 ? Y1 Y2 ?.
  intros a c.
  unfold iff.
  split.
  + intros [b [? ?]].
    b.
    rewrite <- H, <- H0.
    tauto.
  + intros [b [? ?]].
    b.
    rewrite H, H0.
    tauto.
Qed.

Lemma Rel_equiv_union: A,
  Proper (@BinRel.equiv A A ==> @BinRel.equiv A A ==> @BinRel.equiv A A)
    BinRel.union.
Proof.
  unfold Proper, respectful.
  unfold BinRel.equiv, BinRel.union.
  intros A X1 X2 ? Y1 Y2 ?.
  intros.
  rewrite H, H0.
  reflexivity.
Qed.

Lemma Rel_equiv_omega_union: A B (r1 r2: nat -> A -> B -> Prop),
  (n, BinRel.equiv (r1 n) (r2 n)) ->
  BinRel.equiv (BinRel.omega_union r1) (BinRel.omega_union r2).
Proof.
  unfold BinRel.equiv, BinRel.omega_union.
  intros.
  unfold iff; split; intros HH;
  destruct HH as [n ?]; n.
  + rewrite <- H.
    exact H0.
  + rewrite H.
    exact H0.
Qed.

Lemma Rel_equiv_Rel_le: A B (r1 r2: A -> B -> Prop),
  BinRel.equiv r1 r2BinRel.le r1 r2BinRel.le r2 r1.
Proof.
  unfold BinRel.equiv, BinRel.le.
  intros.
  unfold iff at 1.
  split; intros.
  + split; intros ? ?; rewrite H; tauto.
  + destruct H.
    unfold iff; split.
    - apply H.
    - apply H0.
Qed.

Lemma union_comm: A B (r1 r2: A -> B -> Prop),
  BinRel.equiv (BinRel.union r1 r2) (BinRel.union r2 r1).
Proof.
  intros.
  unfold BinRel.equiv, BinRel.union.
  intros.
  tauto.
Qed.

Existing Instances Rel_equiv_refl
                   Rel_equiv_sym
                   Rel_equiv_trans
                   Rel_equiv_test_rel
                   Rel_equiv_concat
                   Rel_equiv_union.
Then we define program equivalence and prove its properties.
Definition com_equiv (c1 c2: com): Prop :=
  BinRel.equiv (ceval c1) (ceval c2).
This just says, two programs c1 and c2 are equivalent when c1 turns st1 to st2 if and only if c2 also turns st1 to st2, for any st1 and st2. This relation is also an equivalence and congruence.
Lemma com_equiv_refl: Reflexive com_equiv.
Proof.
  unfold Reflexive, com_equiv.
  intros.
  reflexivity.
Qed.

Lemma com_equiv_sym: Symmetric com_equiv.
Proof.
  unfold Symmetric, com_equiv.
  intros.
  rewrite H.
  reflexivity.
Qed.

Lemma com_equiv_trans: Transitive com_equiv.
Proof.
  unfold Transitive, com_equiv.
  intros.
  rewrite H, H0.
  reflexivity.
Qed.

Lemma CAss_congr: (X: var),
  Proper (aexp_equiv ==> com_equiv) (CAss X).
Proof.
  unfold Proper, respectful.
  unfold aexp_equiv, com_equiv, BinRel.equiv.
  intros X E E' ?.
  intros st1 st2.
  rewrite ! ceval_CAss.
  unfold Func.equiv in H.
  specialize (H st1).
  rewrite H.
  reflexivity.
Qed.

Lemma CSeq_congr: Proper (com_equiv ==> com_equiv ==> com_equiv) CSeq.
Proof.
  unfold Proper, respectful.
  unfold com_equiv.
  intros c1 c1' ? c2 c2' ?.
  rewrite ! ceval_CSeq.
  rewrite H, H0.
  reflexivity.
Qed.

Lemma CIf_congr:
  Proper (bexp_equiv ==> com_equiv ==> com_equiv ==> com_equiv) CIf.
Proof.
  unfold Proper, respectful.
  unfold bexp_equiv, com_equiv.
  intros b b' ? c1 c1' ? c2 c2' ?.
  rewrite ! ceval_CIf.
  unfold if_sem.
  simpl.
  rewrite H, H0, H1.
  reflexivity.
Qed.

Lemma CWhile_congr:
  Proper (bexp_equiv ==> com_equiv ==> com_equiv) CWhile.
Proof.
  unfold Proper, respectful.
  unfold bexp_equiv, com_equiv.
  intros b b' ? c c' ?.
  rewrite ! ceval_CWhile.
  unfold loop_sem.
  apply Rel_equiv_omega_union.
  intros.
  induction n; simpl.
  + rewrite H.
    reflexivity.
  + rewrite IHn, H, H0.
    reflexivity.
Qed.
Program equivalence is the theoretical foundation of compiler optimization. Let's take a look at some typical examples.
For examples of general equivalence schema, let's start by looking at some trivial program transformations involving Skip:
Theorem skip_left : c,
  com_equiv
    (Skip;; c)
    c.
Proof.
  intros.
  unfold com_equiv, BinRel.equiv.
  intros st1 st2.
  rewrite ceval_CSeq, ceval_CSkip.
  split; intros.
  + unfold concat, id in H.
    destruct H as [st' [? ?]].
    rewrite H.
    exact H0.
  + unfold concat, id.
    st1.
    split.
    - reflexivity.
    - exact H.
Qed.
Also, we can prove that adding a Skip after a command results in an equivalent program.
Theorem skip_right : c,
  com_equiv
    (c ;; Skip)
    c.
Proof.
(* WORKED IN CLASS *)
  intros.
  unfold com_equiv, BinRel.equiv.
  intros st1 st2.
  rewrite ceval_CSeq, ceval_CSkip.
  split; intros.
  + simpl in H.
    unfold concat, id in H.
    destruct H as [st' [? ?]].
    rewrite <- H0.
    exact H.
  + simpl.
    unfold concat, id.
    st2.
    split.
    - exact H.
    - reflexivity.
Qed.
Now we show that we can swap the branches of an IF if we also negate its guard.
Theorem swap_if_branches : b e1 e2,
  com_equiv
    (If b Then e1 Else e2 EndIf)
    (If (BNot b) Then e2 Else e1 EndIf).
Proof.
  intros.
  unfold com_equiv.
  rewrite ! ceval_CIf.
  unfold if_sem; simpl.
  rewrite union_comm.
  rewrite Sets_complement_complement.
  reflexivity.
Qed.
An interesting fact about While commands is that any number of copies of the body can be "unrolled" without changing meaning. Loop unrolling is a common transformation in real compilers.
Theorem loop_unrolling : b c,
  com_equiv
    (While b Do c EndWhile)
    (If b Then (c ;; While b Do c EndWhile) Else Skip EndIf).
Proof.
  intros.
  unfold com_equiv.
  rewrite ceval_CIf, ceval_CSeq, ceval_CSkip.
  rewrite ceval_CWhile.
Abort.
This is not easy to prove. Let's isolate it.
Lemma loop_sem_unrolling: b (R: state -> state -> Prop),
  BinRel.equiv
    (loop_sem b R)
    (if_sem b (BinRel.concat R (loop_sem b R)) BinRel.id).
Proof.
  intros.
  unfold BinRel.equiv; intros st1 st2.
  unfold iff; split; intros.
  + unfold loop_sem, BinRel.omega_union in H.
    destruct H as [n ?].
    destruct n.
    - simpl in H.
      unfold if_sem, BinRel.union.
      right; simpl.
      unfold concat, id.
      st2; split; [exact H | reflexivity].
    - simpl in H.
      unfold if_sem, BinRel.union.
      left.
      unfold concat in H.
      unfold concat.
      destruct H as [st1' [? [st1'' [? ?]]]].
      st1'; split; [exact H |].
      st1''; split; [exact H0 |].
      unfold loop_sem, BinRel.omega_union.
      n.
      exact H1.
  + unfold if_sem, BinRel.union in H.
    unfold loop_sem, BinRel.omega_union.
    destruct H.
    2: {
      0%nat.
      simpl.
      unfold BinRel.concat, BinRel.id in H.
      destruct H as [st2' [? ?]].
      rewrite H0 in H; exact H.
    }
    unfold BinRel.concat at 1 in H.
    destruct H as [st1' [? ?]].
    unfold BinRel.concat in H0.
    destruct H0 as [st0 [? ?]].
    unfold loop_sem, BinRel.omega_union in H1.
    destruct H1 as [n ?].
    (S n).
    simpl.
    unfold BinRel.concat at 1.
    st1'; split; [exact H |].
    unfold BinRel.concat.
    st0; split; [exact H0 | exact H1].
Qed.

Theorem loop_unrolling : b c,
  com_equiv
    (While b Do c EndWhile)
    (If b Then (c ;; While b Do c EndWhile) Else Skip EndIf).
Proof.
  intros.
  unfold com_equiv.
  rewrite ceval_CIf, ceval_CSeq, ceval_CSkip.
  rewrite ceval_CWhile.
  apply loop_sem_unrolling.
Qed.

Bourbaki-Witt Theorem

For now, we have successfully proved that loop_sem is a fixpoint constructor which satisfies the recursive equation loop_sem_unrolling. Remember, x is a fixpoint of f when x = f x. Here, loop_sem b R is a solution of the following equation:
  • X = (if_sem b (concat R X) id) .
Our proof is actually one special case of Bourbaki-Witt fixpoint theorem.

Partial Order

A partial order (偏序) on a set A is a binary relation R (usually written as ) which is reflexive (自反), transitive (传递), and antisymmetric (反对称). Formally,
    xAx ≤ x;
    x y zAx ≤ y -> y ≤ z -> x ≤ z;
    x yAx ≤ y -> y ≤ x -> x = y.
The least element of A w.r.t. a partial order is also called bottom:
    xAbot ≤ x

Chain

A subset of elements in A is called a chain w.r.t. a partial order if any two elements in this subset are comparable. For example, if a sequence xs: nat -> A is monotonically increasing:
    nnatxs n ≤ xs (n + 1),
then it forms a chain.
A partial order is called complete if every chain has its least upper bound lub and greatest lower bound glb. In short, the set A (companied with order ) is called a complete partial ordering, CPO (完备偏序集). Some text books require chains to be nonempty. We do not put such restriction on chain's definition here. Thus, the empty set is a chain. Its least upper bound is the least element of A, in other words, bot.

Monotonic and Continuous Functions

Given two CPOs A, A= and B, B=, a function F: A -> B is called monotonic (单调) if it preserves order. Formally,
    x yAx ≤Ay -> F(x) ≤BF(y).
A function F: A -> B is called continuous (连续) if it preserves lub. Formally,
    xschain(A), lub(F(xs)) = F(lub(xs))
Here, the lub function on the left hand side means the least upper bound defined by B and the one on the right hand side is defined by A.
The definition of continuous does not require the preservation of glb becasue CPOs are usually defined in a direction that larger elements are more defined .

Least fixpoint

Given a CPO A, we can always construct a sequence of elements as follows:
    botF(bot), F(F(bot)), F(F(F(bot))), ...
Obviously, bot F(bot) is true due to the definition of bot. If F is monotonic, it is immediately followed by F(bot) F(F(bot)). Similarly,
    F(F(bot)) ≤ F(F(F(bot))), F(F(F(bot))) ≤ F(F(F(F(bot)))) ...
In other words, if F is monotonic, this sequence is a chain.
Main theorem: given a CPO A, if it has a least element, then every monotonic continuous function F has a fixpoint and the least fixpoint of F is:
    lub [botF(bot), F(F(bot)), F(F(F(bot))), ...].
Proof.
On one hand, this least upper bound is a fixpoint:
    F (lub [botF(bot), F(F(bot)), F(F(F(bot))), ...]) =
    lub [F(bot), F(F(bot)), F(F(F(bot))), F(F(F(F(bot)))), ...] =
    lub [botF(bot), F(F(bot)), F(F(F(bot))), ...].
The first equality is true because F is continuous. The second equality is true because bot is less than or equal to all other elements in the sequence.
On the other hand, this fixpoint is the least one. For any other fixpoint x, in other words, suppose F(x) = x. Then,
    bot ≤ x
Thus,
    F(bot) ≤ F(x) = x
due to the fact that F is monotonic and x is a fixpoint. And so on,
    F(F(bot)) ≤ xF(F(F(bot))) ≤ xF(F(F(F(bot)))) ≤ x, ...
That means, x is an upper bound of bot, F(bot), F(F(bot)), .... It must be greater than or equal to
    lub [botF(bot), F(F(bot)), F(F(F(bot))), ...].
QED.

Denotation of Loops as Bourbaki-Witt Fixpoint

Our definition loop_sem is actually a Bourbaki-Witt fixpoint of the recursive equation defined by loop_sem_unrollong. In this case, set A is the set of binary relations between program stats, i.e. A := state->state->Prop.
The equivalence relation defined on A is Rel.equiv. The partial order defined on A is the subset relation, i.e. Rel.le. This partial ordering is a CPO. The least upper bound, lub, of a chain is the union of all binary relations in the chain. Specifically, omega_union defines the lub of a sequence of relations.
In the end, the function that maps X to if_sem b (concat R X) id) is monotonic and continuous. And loop_sem is exactly the Bourbaki-Witt fixpoint of this function.
(* 2021-03-17 12:59 *)