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