For the Church encoding N of positive integers, one can define a recursion principle nat_rec :
Definition N : Type :=
forall (X:Type), X->(X->X)->X.
Definition nat_rec (z:N)(s:N->N)(n:N) : N :=
n N z s.
What is the recursion principle equal_rec for the following Church encoding equal of equality?
Definition equal (x:A) : A->Type :=
fun x' => forall (P:A->Type), P x -> P x'.
Definition equal_rec (* ... *)
Like the case of natural numbers, the recursion principle is simply an eta expansion:
Definition equal (A:Type) (x:A) : A->Type :=
fun x' => forall (P:A->Type), P x -> P x'.
Definition equal_rec (A:Type) (x y : A) (e : equal x y) (P : A -> Type) : P x -> P y :=
e P.
Related
Context: I have been trying to implement the unification algorithm (the algorithm to find the most general unifier of two abstract syntax trees). Since a unifier is a substitution, algorithm requires defining composition of substitutions.
To be specific, given a type treeSigma dependent on another type X, a substitution is a function of type:
X -> treeSigma X
and the function substitute takes a substitution as an input and has type
substitute: (X-> (treeSigma X))-> (treeSigma X) -> (treeSigma X)
I need to define a function to compose two substitutions:
compose_kleisli (rho1 rho2: X->(treeSigma X)) : (treeSigma X) := ...
such that,
forall tr: treeSigma X,
substitute (compose_kleisli rho1 rho2) tr = substitute rho1 (substitute rho2 tr).
I am fairly new to coq and have been stuck with defining this composition.
How can I define this composition?
I tried to define it using Record like this:
Record compose {X s} (rho1 rho2: X-> treeSigma X):= mkCompose{
RHO: X-> treeSigma X;
CONDITION: forall t, substitute RHO t = substitute rho2 (substitute rho1 t)
}.
but along with this, I would need to prove the result that the composition can be defined for any two substitutions. Something like:
Theorem composeTotal: forall {X s} (rho1 rho2: X-> treeSigma s X), exists rho3,
forall t, substitute rho3 t = substitute rho2 (substitute rho1 t).
Proving this would require a construction of rho3 which circles back to the same problem of defining compose.
treeSigma is defined as:
(* Signature *)
Record sigma: Type := mkSigma {
symbol : Type;
arity : symbol -> nat
}.
Record sigmaLeaf (s:sigma): Type := mkLeaf {
cLeaf: symbol s;
condLeaf: arity s cLeaf = 0
}.
Record sigmaNode (s:sigma): Type := mkNode {
fNode: symbol s;
condNode: arity s fNode <> 0
}.
(* Sigma Algebra *)
Record sigAlg (s:sigma) (X:Type) := mkAlg {
Carrier: Type;
meaning: forall f:(sigmaNode s), (Vector.t Carrier (arity s (fNode s f))) -> Carrier;
meanLeaf: forall f:(sigmaLeaf s), Vector.t Carrier 0 -> Carrier
}.
(* Abstract tree on arbitrary signature. *)
Inductive treeSigma (s:sigma) (X:Type):=
| VAR (x:X)
| LEAF (c: sigmaLeaf s)
| NODE (f: sigmaNode s) (sub: Vector.t (treeSigma s X) (arity s (fNode s f)) ).
(* Defining abstract syntax as a sigma algebra. *)
Definition meanTreeNode {s X} (f:sigmaNode s) (sub: Vector.t (treeSigma s X) (s.(arity)
(fNode s f))): treeSigma s X:= NODE s X f sub.
Definition meanTreeLeaf {s X} (c:sigmaLeaf s) (sub: Vector.t (treeSigma s X) 0) := LEAF s X c.
Definition treeSigAlg {s X} := mkAlg s X (treeSigma s X) meanTreeNode meanTreeLeaf.
The substitution function is defined as:
Fixpoint homoSigma1 {X:Type} {s} (A: sigAlg s X) (rho: X-> (Carrier s X A))
(wft: (treeSigma s X)) {struct wft}: (Carrier s X A) :=
match wft with
| VAR _ _ x => rho x
| LEAF _ _ c => meanLeaf s X A c []
| NODE _ _ f l2 => meanNode s X A f (
(fix homoSigVec k (l2:Vector.t _ k):= match l2 with
| [] => []
| t::l2s => (homoSigma1 A rho t):: (homoSigVec (vlen _ l2s) l2s)
end)
(arity s (fNode s f)) l2)
end.
Definition substitute {X s} (rho: X-> treeSigma s X) (t: treeSigma s X) := #homoSigma1 X s treeSigAlg rho t.
To be particular, a substitution is the homomorphic extension of rho (which is a variable valuation).
Definitions like this are challenging to work with because the tree type occurs recursively inside of another inductive type. Coq has trouble generating induction principles for these types on its own, so you need to help it a little bit. Here is a possible solution, for a slightly simplified set up:
Require Import Coq.Vectors.Vector.
Import VectorNotations.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Section Dev.
Variable symbol : Type.
Variable arity : symbol -> nat.
Record alg := Alg {
alg_sort :> Type;
alg_op : forall f : symbol, Vector.t alg_sort (arity f) -> alg_sort;
}.
Arguments alg_op {_} f _.
(* Turn off the automatic generation of induction principles.
This tree type does not distinguish between leaves and nodes,
since they only differ in their arity. *)
Unset Elimination Schemes.
Inductive treeSigma (X:Type) :=
| VAR (x:X)
| NODE (f: symbol) (args : Vector.t (treeSigma X) (arity f)).
Arguments NODE {X} _ _.
Set Elimination Schemes.
(* Manual definition of a custom induction principle for treeSigma.
HNODE is the inductive case for the NODE constructor; the vs argument is
saying that the induction hypothesis holds for each tree in the vector of
arguments. *)
Definition treeSigma_rect (X : Type) (T : treeSigma X -> Type)
(HVAR : forall x, T (VAR x))
(HNODE : forall f (ts : Vector.t (treeSigma X) (arity f))
(vs : Vector.fold_right (fun t V => T t * V)%type ts unit),
T (NODE f ts)) :
forall t, T t :=
fix loopTree (t : treeSigma X) : T t :=
match t with
| VAR x => HVAR x
| NODE f ts =>
let fix loopVector n (ts : Vector.t (treeSigma X) n) :
Vector.fold_right (fun t V => T t * V)%type ts unit :=
match ts with
| [] => tt
| t :: ts => (loopTree t, loopVector _ ts)
end in
HNODE f ts (loopVector (arity f) ts)
end.
Definition treeSigma_ind (X : Type) (T : treeSigma X -> Prop) :=
#treeSigma_rect X T.
Definition treeSigma_alg (X:Type) : alg := {|
alg_sort := treeSigma X;
alg_op := #NODE X;
|}.
Fixpoint homoSigma {X : Type} {Y : alg} (ρ : X -> Y) (t : treeSigma X) : Y :=
match t with
| VAR x => ρ x
| NODE f xs => alg_op f (Vector.map (homoSigma ρ) xs)
end.
Definition substitute X (ρ : X -> treeSigma X) (t : treeSigma X) : treeSigma X :=
#homoSigma X (treeSigma_alg X) ρ t.
(* You can define composition simply by applying using substitution. *)
Definition compose X (ρ1 ρ2 : X -> treeSigma X) : X -> treeSigma X :=
fun x => substitute ρ1 (ρ2 x).
(* The property you are looking for follows by induction on the tree. Note
that this requires a nested induction on the vector of arguments. *)
Theorem composeP X (ρ1 ρ2 : X -> treeSigma X) t :
substitute (compose ρ1 ρ2) t = substitute ρ1 (substitute ρ2 t).
Proof.
unfold compose, substitute.
induction t as [x|f ts IH]; trivial.
simpl; f_equal.
induction ts as [|n t ts IH']; trivial.
simpl.
destruct IH as [e IH].
rewrite e.
f_equal.
now apply IH'.
Qed.
End Dev.
In order to do this you need to use the operations of the monad, typically:
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Section MonadKleisli.
(* Set Universe Polymorphism. // Needed for real use cases *)
Variable (M : Type -> Type).
Variable (Ma : forall A B, (A -> B) -> M A -> M B).
Variable (η : forall A, A -> M A).
Variable (μ : forall A, M (M A) -> M A).
(* Compose: o^* *)
Definition oStar A B C (f : A -> M B) (g: B -> M C) : A -> M C :=
fun x => μ (Ma g (f x)).
(* Bind *)
Definition bind A B (x : M A) (f : A -> M B) : M B := oStar (fun _ => x) f tt.
End MonadKleisli.
Depending on how you organize your definitions, proving your desired properties will likely require functional extensionality, not a big deal usually but something to keep in ind.
Implementing vector addition in some of the dependently typed languages (such as Idris) is fairly straightforward. As per the example on Wikipedia:
import Data.Vect
%default total
pairAdd : Num a => Vect n a -> Vect n a -> Vect n a
pairAdd Nil Nil = Nil
pairAdd (x :: xs) (y :: ys) = x + y :: pairAdd xs ys
(Note how Idris' totality checker automatically infers that addition of Nil and non-Nil vectors is a logical impossibility.)
I am trying to implement the equivalent functionality in Coq, using a custom vector implementation, albeit very similar to the one provided in the official Coq libraries:
Set Implicit Arguments.
Inductive vector (X : Type) : nat -> Type :=
| vnul : vector X 0
| vcons {n : nat} (h : X) (v : vector X n) : vector X (S n).
Arguments vnul [X].
Fixpoint vpadd {n : nat} (v1 v2 : vector nat n) : vector nat n :=
match v1 with
| vnul => vnul
| vcons _ x1 v1' =>
match v2 with
| vnul => False_rect _ _
| vcons _ x2 v2' => vcons (x1 + x2) (vpadd v1' v2')
end
end.
When Coq attempts to check vpadd, it yields the following error:
Error:
In environment
vpadd : forall n : nat, vector nat n -> vector nat n -> vector nat n
[... other types]
n0 : nat
v1' : vector nat n0
n1 : nat
v2' : vector nat n1
The term "v2'" has type "vector nat n1" while it is expected to have type "vector nat n0".
Note that, I use False_rect to specify the impossible case, otherwise the totality check wouldn't pass. However, for some reason the type checker doesn't manage to unify n0 with n1.
What am I doing wrong?
It's not possible to implement this function so easily in plain Coq: you need to rewrite your function using the convoy pattern. There was a similar question posted a while ago about this. The idea is that you need to make your match return a function in order to propagate the relation between the indices:
Set Implicit Arguments.
Inductive vector (X : Type) : nat -> Type :=
| vnul : vector X 0
| vcons {n : nat} (h : X) (v : vector X n) : vector X (S n).
Arguments vnul [X].
Definition vhd (X : Type) n (v : vector X (S n)) : X :=
match v with
| vcons _ h _ => h
end.
Definition vtl (X : Type) n (v : vector X (S n)) : vector X n :=
match v with
| vcons _ _ tl => tl
end.
Fixpoint vpadd {n : nat} (v1 v2 : vector nat n) : vector nat n :=
match v1 in vector _ n return vector nat n -> vector nat n with
| vnul => fun _ => vnul
| vcons _ x1 v1' => fun v2 => vcons (x1 + vhd v2) (vpadd v1' (vtl v2))
end v2.
This is the definition for exp in group theory:
Definition exp : Z -> U -> U.
Proof.
intros n a.
elim n;
clear n.
exact e.
intro n.
elim n; clear n.
exact a.
intros n valrec.
exact (star a valrec).
intro n; elim n; clear n.
exact (inv a).
intros n valrec.
exact (star (inv a) valrec).
Defined.
I tried to define a ((a^n)^k) this way.
Definition exp2 (n k : Z) (a : U) := fun a => exp k (exp n a).
But exp k (exp n a) is of type U->U but I want it to be of type U. How can I do it?
As Gilles pointed out, the signature of your exp2 function is equivalent to
Definition exp2 (n k : Z) (a a(*won't work in Coq*) : U) :=
exp k (exp n a).
You need to remove one of the a:
Definition exp2 (n k : Z) (a : U) := exp k (exp n a).
Definition exp2_alt (n k : Z) : fun a => exp k (exp n a).
I am interested in how would one define f to the n in Coq:
Basically, as an exercise, I would like to write this definition and then confirm that my
algorithm implements this specification. Inductive definition seems appropriate here, but I was not able to make it clean as above. What would be a clean Coq implementation of the above?
With the pow_func function that gallais defined, you can state your specification as lemmas, such as:
Lemma pow_func0: forall (A:Type) (f: A -> A) (x: A), pow_fun f O x = f x.
and
Lemma pow_funcS: forall (n:nat) (A: Type) (f: A->A) (x:A), pow_fun f (S n) x = f (pow_fun f n x).
The proof should be trivial by unfolding the definition
Inductive is used to define types closed under some operations; this is not what you are looking for here. What you want to build is a recursive function iterating over n. This can be done using the Fixpoint keyword:
Fixpoint pow_func {A : Type} (f : A -> A) (n : nat) (a : A) : A :=
match n with
| O => f a
| S n => f (pow_func f n a)
end.
If you want a nicer syntax for this function, you can introduce a Notation:
Notation "f ^ n" := (pow_func f n).
However, note that this is not a well-behaved definition of a notion of power: if you compose f ^ m and f ^ n, you don't get f ^ (m + n) but rather f ^ (1 + m + n). To fix that, you should pick the base case f ^ 0 to be the neutral element for composition id rather than f itself. Which would give you:
Fixpoint pow_func' {A : Type} (f : A -> A) (n : nat) (a : A) : A :=
match n with
| O => a
| S n => f (pow_func' f n a)
end.
I've started working a lot with Ensembles now, because they are more flexible. To help me with that, I'm trying to define some convenient notations. The following is relatively easy, for example:
Notation "a ∈ S" := (#In _ S a) (at level 80).
And I can add a similar bunch for the other binary set operators.
But I'm having a lot of trouble with notations like this:
Notation "∀ x ∈ S , P" := (forall x, (x ∈ S) -> P) (at level 90).
It is accepted, but whenever I try to use it I get this error:
Syntax error: "∈" expected after [constr:operconstr level 200] (in [constr:operconstr]).
Question 1: What am I doing wrong?
For bonus points, can you tell me how to define a recursive notation for it? I've tried, but it seems to give me a whole new set of problems. Here's my attempt, a straightforward edit of the library definition:
Notation "∀ x .. y ∈ S , P" :=
(forall x, (x ∈ S) -> .. (forall y, (y ∈ S) -> P) ..)
(at level 200, x binder, y binder, right associativity).
I don't see why the library version in Coq.Unicode.Utf8_core should parse and mine shouldn't, but:
Error: Cannot find where the recursive pattern starts.
Question 2: See question 1.
The reason that the recursive notation above didn't work is that binders (in this case x and y) can only be used in one of two specific locations in the right hand side [see manual]:
at the binder location in a fun [ ] => ... term, or
at the binder location in a forall [ ], ... term.
So, I could not use them again as terms. This seems somewhat arbitrary to me, since binders are terms within their binding context. However, you can do pretty much anything you want with the fun route:
Definition all_in_E `(E: Ensemble T, P: T → Prop) : T → Prop :=
(λ x: T, (x ∈ E) → (P x)).
Notation "∀ x .. y ∈ S , P" :=
( all ( all_in_E S ( fun x => .. ( all ( all_in_E S ( fun y => P ))) .. )))
(at level 200, x closed binder, y closed binder, right associativity).
Definition ex_in_E `(E: Ensemble T, P: T → Prop) : T → Prop :=
(λ x: T, (x ∈ E) ∧ (P x)).
Notation "∃ x .. y ∈ S , P" :=
( ex ( ex_in_E S ( fun x => .. ( ex ( ex_in_E S ( fun y => P ))) .. )))
(at level 200, x closed binder, y closed binder, right associativity).
The functions all_in_E and ex_in_E take a predicate (a fun) and augment it with a condition for membership in a given ensemble E. It's taking the long way around, but it works.
Here's a fully working block of code with examples:
Require Export Coq.Unicode.Utf8.
Require Export Coq.Sets.Ensembles.
Generalizable All Variables.
Notation "a ∈ S" := (#In _ S a) (at level 70, no associativity).
Notation "A ∪ B" := (#Union _ A B) (at level 50, left associativity).
Notation "A ∩ B" := (#Intersection _ A B) (at level 40, left associativity).
Definition all_in_E `(E: Ensemble T, P: T → Prop) : T → Prop :=
(λ x: T, (x ∈ E) → (P x)).
Notation "∀ x .. y ∈ S , P" :=
( all ( all_in_E S ( fun x => .. ( all ( all_in_E S ( fun y => P ))) .. )))
(at level 200, x closed binder, y closed binder, right associativity).
Definition ex_in_E `(E: Ensemble T, P: T → Prop) : T → Prop :=
(λ x: T, (x ∈ E) ∧ (P x)).
Notation "∃ x .. y ∈ S , P" :=
( ex ( ex_in_E S ( fun x => .. ( ex ( ex_in_E S ( fun y => P ))) .. )))
(at level 200, x closed binder, y closed binder, right associativity).
Section TestingEnsembleQuantifiers.
Definition A_nat := Full_set nat.
Definition E_nat := Empty_set nat.
Definition F_nat := Singleton _ 5.
Require Import Coq.Arith.Gt.
Example exists_in_intersection: ∃ x ∈ A_nat ∩ F_nat , x = 5.
unfold ex_in_E.
exists 5.
split ; trivial.
split.
apply Full_intro.
apply In_singleton.
Qed.
Example forall_in_union: ∀ x ∈ F_nat ∪ E_nat, x ≥ 5.
unfold all_in_E, all.
intros.
destruct H ; destruct H.
auto with arith.
Qed.
End TestingEnsembleQuantifiers.
Please note also the new precedence levels for the set operators, which make more sense in relation to the existing precedence levels [see manual].