(* Formalizing and Proving Theorems in Coq --- Homework 7
curated by Tobias KappĂ©, May 2022.
This file demonstrates the use of records to encode different algebraic
signatures, as well as the Program vernacular to fill in proofs.
There are no homework exercises. *)
Require Import Coq.Lists.List.
Require Import Coq.Program.Tactics.
(* Here is a definition of a monoid as an object with a carrier, an operation,
and a constant satisfying the monoid laws. This means that every instance
of a monoid carries around proofs of these facts. *)
Record monoid := {
carrier: Type;
mult: carrier -> carrier -> carrier;
unit: carrier;
associativity: forall c1 c2 c3, mult (mult c1 c2) c3 = mult c1 (mult c2 c3);
unit_left: forall c, mult unit c = c;
unit_right: forall c, mult c unit = c;
}.
(* Let's try to define the "free monoid" over X, which consists of lists of
elements over X, with appending as operation and the empty list as unit. *)
Fail Definition free_monoid (X: Type) := {|
carrier := list X;
mult := app (A := X);
unit := nil;
|}.
(* Oops, we should also provide proofs of the operations! One way to do this
is to use the associativity, unit_left, and unit_right fields to point to
a lemma of the appropriate type. But writing down this definition is a bit
cumbersome. What we do instead is use the Program vernacular to let Coq
*generate* the missing fields for us, as follows. *)
Program Definition free_monoid (X: Type) := {|
carrier := list X;
mult := app (A := X);
unit := nil;
|}.
(* Notice that we are left with two obligations, one for associativity and one
for unit_right. The one for unit_left was automatically cleared by Coq's
automation, which is a nice bonus. *)
Next Obligation.
(* Coq has a built-in lemma about associativity of appending that we use. *)
Search (_ ++ _ ++ _).
now rewrite app_assoc.
Qed.
Next Obligation.
(* Appending nil on the right is also encoded in a lemma. *)
Search (_ ++ nil).
now rewrite app_nil_r.
Qed.
(* Here is a definition of a predicate asserting that a function from the
carrier of one monoid to another is a homomorphism. We have encoded this
into a record, with a field for either property. Also note the implicit
parameters in the form of monoids! *)
Record homomorphism {m1 m2: monoid} (f: carrier m1 -> carrier m2) := {
preserve_unit: f (unit m1) = unit m2;
preserve_mult: forall c1 c2, f (mult m1 c1 c2) = mult m2 (f c1) (f c2);
}.
(* Alternative definition. *)
Definition homomorphism' {m1 m2: monoid} (f: carrier m1 -> carrier m2) :=
f (unit m1) = unit m2 /\
forall c1 c2, f (mult m1 c1 c2) = mult m2 (f c1) (f c2)
.
(* This function takes a map from a set X to the carrier of a monoid, and
extends it to a map from lists over X to the carrier of that monoid. *)
Fixpoint lift_morphism
{X: Type}
{m: monoid}
(f: X -> carrier m)
(l: carrier (free_monoid X))
:=
match l with
| nil => unit m
| cons x l => mult m (f x) (lift_morphism f l)
end
.
(* The lifting of a map as done above is indeed a homomorphism. *)
Lemma lifted_morphism_is_homomorphism
{X: Type}
{m: monoid}
(f: X -> carrier m)
:
homomorphism (lift_morphism f)
.
Proof.
(* We prove the properties separately. *)
split.
- reflexivity.
- intros.
simpl.
induction c1.
+ simpl.
(* This is where the monoid laws can be used. *)
now rewrite unit_left.
+ simpl.
rewrite associativity.
now rewrite IHc1.
Qed.
(* We need to extend our logic for what we are about to do. *)
Require Import Coq.Logic.FunctionalExtensionality.
(* Indeed, the lifted morphism is the *only* homomorphism satisfying a certain
property, namely that it acts like the function being lifted when applied
to one-element lists. *)
Lemma lifted_morphism_determined
{X: Type}
(m: monoid)
(f: X -> carrier m)
(h: carrier (free_monoid X) -> carrier m)
:
homomorphism h ->
(forall x, h (cons x nil) = f x) ->
lift_morphism f = h
.
Proof.
intros.
(* To prove functions equal, we prove that they act the same on all arguments
by using the "extensionality" tactic. *)
extensionality x.
destruct H.
induction x.
- simpl in preserve_unit0.
rewrite preserve_unit0.
simpl.
reflexivity.
- simpl.
rewrite IHx.
rewrite <- H0.
rewrite <- preserve_mult0.
simpl.
reflexivity.
Qed.
(* Assuming extensionality adds an extra axiom to Coq's underlying logic. You
can use the following vernacular to find out which assumptions were used
when writing a proof. *)
Print Assumptions lifted_morphism_determined.
(* We can now prove that the free monoid is indeed free in the categorical
sense, namely that it gives rise to *exactly* one monoid homomorphism for
every map into the underlying carrier of another monoid. *)
Lemma free_monoid_is_free (X: Type) (m: monoid) (f: X -> carrier m):
exists! h: carrier (free_monoid X) -> carrier m,
homomorphism h /\ forall x, h (cons x nil) = f x
.
Proof.
exists (lift_morphism f).
split.
- split.
+ apply lifted_morphism_is_homomorphism.
+ simpl.
intros.
rewrite unit_right.
reflexivity.
- intros.
apply lifted_morphism_determined.
+ intuition.
+ intuition.
Qed.
(* As an encore, here is how you can define a monoid product using the Program
vernacular to fill in the requisite properties. *)
Program Definition monoid_product (m1 m2: monoid) := {|
carrier := carrier m1 * carrier m2;
mult := fun x1 x2 =>
(mult m1 (fst x1) (fst x2), mult m2 (snd x1) (snd x2));
unit := (unit m1, unit m2);
|}.
Next Obligation.
simpl.
f_equal.
- now rewrite associativity.
- now rewrite associativity.
Qed.
Next Obligation.
simpl.
f_equal.
- now rewrite unit_left.
- now rewrite unit_left.
Qed.
Next Obligation.
simpl.
f_equal.
- now rewrite unit_right.
- now rewrite unit_right.
Qed.