(** 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
| CSkip => BinRel.id
| CAss X E =>
fun st1 st2 =>
st2 X = aeval E st1 /\
forall Y, X <> Y -> st1 Y = st2 Y
| CSeq c1 c2 => BinRel.concat (ceval c1) (ceval c2)
| CIf b c1 c2 => if_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: forall st1 st2,
The_pair_( st1 , st2 )_is_in_{[ Skip ]} <->
st1 = st2.
Proof.
intros.
simpl.
unfold id.
tauto.
Qed.
Lemma ceval_seq: forall st1 st3 c1 c2,
The_pair_( st1 , st3 )_is_in_{[ c1;; c2 ]} <->
exists 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: forall 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.
exists st1.
tauto.
- right.
exists 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 st2 => exists n, 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
| CSkip => BinRel.id
| CAss X E =>
fun st1 st2 =>
st2 X = aeval E st1 /\
forall Y, X <> Y -> st1 Y = st2 Y
| CSeq c1 c2 => BinRel.concat (ceval c1) (ceval c2)
| CIf b c1 c2 => if_sem b (ceval c1) (ceval c2)
| CWhile b c => loop_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: forall X E,
ceval (CAss X E) =
fun st1 st2 =>
st2 X = aeval E st1 /\
forall Y, X <> Y -> st1 Y = st2 Y.
Proof. intros. simpl. reflexivity. Qed.
Lemma ceval_CSeq: forall c1 c2,
ceval (c1 ;; c2) = BinRel.concat (ceval c1) (ceval c2).
Proof. intros. simpl. reflexivity. Qed.
Lemma ceval_CIf: forall b c1 c2,
ceval (CIf b c1 c2) = if_sem b (ceval c1) (ceval c2).
Proof. intros. simpl. reflexivity. Qed.
Lemma ceval_CWhile: forall 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: forall (X: var) (st: state), ~ exists st',
The_pair_( st , st' )_is_in_{[ While true Do X ::= X + 1 EndWhile ]}.
Proof.
intros.
pose proof
classic
(exists 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: forall (X: var) st, exists st',
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 Y => if (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: forall 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: forall st X v,
(forall Y, X <> Y -> 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: forall st X v,
(state_update st X v) X = v /\
(forall Y, X <> Y -> 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: forall (X: var) st, exists st',
The_pair_( st , st' )_is_in_{[ X ::= 2;;
While 1 <= X Do X ::= X - 1 EndWhile ]}.
Proof.
intros.
exists (state_update st X 0).
rewrite ceval_CSeq.
unfold concat.
exists (state_update st X 2).
split.
+ rewrite ceval_CAss.
apply state_update_spec.
+ rewrite ceval_CWhile.
unfold loop_sem, BinRel.omega_union.
exists 2%nat.
simpl.
unfold BinRel.concat at 1.
exists (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.
exists (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.
exists (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.
exists (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: forall A, Reflexive (@Sets.equiv A).
Proof.
unfold Reflexive, Sets.equiv.
intros.
reflexivity.
Qed.
Lemma Sets_equiv_sym: forall A, Symmetric (@Sets.equiv A).
Proof.
unfold Symmetric, Sets.equiv.
intros.
rewrite H.
reflexivity.
Qed.
Lemma Sets_equiv_trans: forall A, Transitive (@Sets.equiv A).
Proof.
unfold Transitive, Sets.equiv.
intros.
rewrite H, H0.
reflexivity.
Qed.
Lemma Func_test_eq_equiv: forall 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: forall 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: forall 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: forall 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: forall 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 :=
forall a b, r1 a b <-> r2 a b.
Definition le {A B: Type} (r1 r2: A -> B -> Prop): Prop :=
forall a b, r1 a b -> r2 a b.
End BinRel.
(** Here is its properties. *)
Lemma Rel_equiv_refl: forall A B, Reflexive (@BinRel.equiv A B).
Proof.
unfold Reflexive, BinRel.equiv.
intros.
reflexivity.
Qed.
Lemma Rel_equiv_sym: forall A B, Symmetric (@BinRel.equiv A B).
Proof.
unfold Symmetric, BinRel.equiv.
intros.
rewrite H.
reflexivity.
Qed.
Lemma Rel_equiv_trans: forall A B, Transitive (@BinRel.equiv A B).
Proof.
unfold Transitive, BinRel.equiv.
intros.
rewrite H, H0.
reflexivity.
Qed.
Lemma Rel_equiv_test_rel: forall 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: forall 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 [? ?]].
exists b.
rewrite <- H, <- H0.
tauto.
+ intros [b [? ?]].
exists b.
rewrite H, H0.
tauto.
Qed.
Lemma Rel_equiv_union: forall 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: forall A B (r1 r2: nat -> A -> B -> Prop),
(forall 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 ?]; exists n.
+ rewrite <- H.
exact H0.
+ rewrite H.
exact H0.
Qed.
Lemma Rel_equiv_Rel_le: forall A B (r1 r2: A -> B -> Prop),
BinRel.equiv r1 r2 <-> BinRel.le r1 r2 /\ BinRel.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: forall 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: forall (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 : forall 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.
exists 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 : forall 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.
exists 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 : forall 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 : forall 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: forall 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.
exists 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'' [? ?]]]].
exists st1'; split; [exact H |].
exists st1''; split; [exact H0 |].
unfold loop_sem, BinRel.omega_union.
exists n.
exact H1.
+ unfold if_sem, BinRel.union in H.
unfold loop_sem, BinRel.omega_union.
destruct H.
2: {
exists 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 ?].
exists (S n).
simpl.
unfold BinRel.concat at 1.
exists st1'; split; [exact H |].
unfold BinRel.concat.
exists st0; split; [exact H0 | exact H1].
Qed.
Theorem loop_unrolling : forall 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,
forall x: A, x <= x;
forall x y z: A, x <= y -> y <= z -> x <= z;
forall x y: A, x <= y -> y <= x -> x = y.
The least element of [A] w.r.t. a partial order [<=] is also called bottom:
forall x: A, bot <= 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:
forall n: nat, xs 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,
forall x y: A, x <=A= y -> F(x) <=B= F(y).
A function [F: A -> B] is called continuous (连续) if it preserves [lub].
Formally,
forall xs: chain(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:
bot, F(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 [bot, F(bot), F(F(bot)), F(F(F(bot))), ...].
Proof.
On one hand, this least upper bound is a fixpoint:
F (lub [bot, F(bot), F(F(bot)), F(F(F(bot))), ...]) =
lub [F(bot), F(F(bot)), F(F(F(bot))), F(F(F(F(bot)))), ...] =
lub [bot, F(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)) <= x, F(F(F(bot))) <= x, F(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 [bot, F(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 *)