I am trying to use List.map in recursive definition, mapping over a list using currently defined recursive function as an argument. Is it possible at all? I can define my own recursive fixpoint definition instead of using map but I am interested in using map here.
Require Import Coq.Lists.List.
Import ListNotations.
Inductive D: nat -> Type := | D0 (x:nat): D x.
Inductive T: nat -> nat -> Type :=
| T0 {i o} (foo:nat): T i o
| T1 {i o} (foo bar:nat) : T i o -> T i o.
Fixpoint E {i o: nat} (t:T i o) (x:nat) (d:D i): option (D o)
:=
(match t in #T i o
return D i -> option (D o)
with
| T0 _ _ foo => fun d0 => None
| T1 _ _ foo bar t' =>
fun d0 =>
let l := List.map (fun n => E t' x d0) [ 1 ; 2 ; 3 ] in
let default := Some (D0 o) in
List.hd default l
end) d.
The example above is artificial, but demonstrates the problem. The error message:
The term "l" has type "list (option (D n0))"
while it is expected to have type "list (option (D o))".
You just need to bind the names on the T1 pattern:
Require Import Coq.Lists.List.
Import ListNotations.
Inductive D: nat -> Type := | D0 (x:nat): D x.
Inductive T: nat -> nat -> Type :=
| T0 {i o} (foo:nat): T i o
| T1 {i o} (foo bar:nat) : T i o -> T i o.
Fixpoint E {i o: nat} (t:T i o) (x:nat) (d:D i): option (D o)
:=
(match t in #T i o
return D i -> option (D o)
with
| T0 _ _ foo => fun d0 => None
(* \/ change here *)
| T1 i o foo bar t' =>
fun d0 =>
let l := List.map (fun n => E t' x d0) [ 1 ; 2 ; 3 ] in
let default := Some (D0 o) in
List.hd default l
end) d.
The problem is that omitting the binders means that the o used on the T1 branch refers to the "outer" variable of the same name, whereas you want it to refer to the one given by T1.
Related
I am very new to Haskell and I wrote a Data Type in Haskell
for representing an interval map.
What does that mean? Briefly: A map data type that gives you a value back
for every possible key (put simply in my case [0..]).
Then you insert "sequences" like I want my map to hold from 7 to 23 'b'
so keys 0 to 6 will be init value e.g. 'a' and 7 to 23 will be 'b' and 24 and ongoing will be 'a' again etc.
I managed to wrote the Data Type, a get and insert function as well as a
functor version.
But I can't managed to get a applicative functor version to work.
The idea is to set the keys value to [0..] and just work on the values.
Here is my code and thanks for any provided help!
-- Building an interval map data structure in haskell
data IntervalMap k v = IntervalMap {keys :: [k] , values :: [v]} | Empty deriving Show
-- k = key, Typ variable
-- v = value, Typ variable
singleton :: (Enum k, Num k) => v -> IntervalMap k v
singleton v = IntervalMap{keys=[0..], values= repeat v}
-- get operator => a ! 5 = value at position 5
(!) :: Ord k => IntervalMap k v -> k -> v
(!) iMap k = snd (head (filter (\(x, y) -> x == k) (zip (keys iMap) (values iMap)) ))
-- insert a sequence into intervalMap
insert :: (Ord k, Num k, Enum k) => k -> k -> v -> IntervalMap k v -> IntervalMap k v
insert start end value iMap = IntervalMap {keys=keys iMap, values = rangeChanger (values iMap) start end value}
-- helper function to change a range of values in an intervalMap
rangeChanger :: (Num a1, Enum a1, Ord a1) => [a2] -> a1 -> a1 -> a2 -> [a2]
rangeChanger iMapValues start end value = [if (i >= start) && (i <= end) then newValue else iMapValue | (iMapValue, newValue, i) <- zip3 iMapValues (repeat value) [0..]]
-- functor instance for intervalMap
instance Functor (IntervalMap k) where
-- fmap :: (a -> b) -> f a -> f b
fmap f iMap = IntervalMap {keys=keys iMap, values= map f (values iMap) }
-- applicative functor for intervalMap
instance (Ord k, Num k, Enum k) => Applicative (IntervalMap k) where
pure k = IntervalMap{keys=[0..], values=repeat k}
_ <*> Nothing = Nothing
-- HOW TO DO?
-- class Functor functor => Applicative functor where
-- pure :: a -> functor a
-- (<*>) :: functor (a -> b) -> functor a -> functor b
-- (*>) :: functor a -> functor b -> functor b
-- (<*) :: functor a -> functor b -> functor a
It seems like you always expect the keys to be [0..], e.g. it is hard-coded in your rangeChanger function. If that is the case then it is redundant and honestly I would leave it out. You can easily reconstruct it by doing something like zip [0..] (values iMap) as you do in the rangeChanger function.
If you make that change, then your IntervalMap data structure is basically the same as ZipList which has an applicative instance here:
instance Applicative ZipList where
pure x = ZipList (repeat x)
liftA2 f (ZipList xs) (ZipList ys) = ZipList (zipWith f xs ys)
You see that this doesn't define a <*> but that can be defined in terms of liftA2: p <*> q = liftA2 (\f x -> f x) p q, so you could also write that explicitly for ZipList:
ZipList fs <*> ZipList xs = ZipList (zipWith (\f x -> f x) fs xs)
Edit: I should also mention that one difference with ZipList is that you have an Empty constructor for your IntervalMap type. That makes things harder, you would need to know that your values have some sort of default value, but that is not possible in general (not every type has a default value), so your type cannot be an Applicative. Do you really need that Empty case?
Consider the following Coq program:
Inductive foo : nat -> Type :=
| nil : foo 0
| succ{n:nat} : foo n -> foo n.
Fixpoint bar {n:nat}(A:foo n)(B:foo n) : Prop :=
match B with
| nil => False
| succ C => bar A C
end.
Coq complains on the definition of bar:
In environment
bar : forall n : nat, foo n -> foo n -> Prop
n : nat
A : foo n
B : foo n
n0 : nat
C : foo n0
The term "C" has type "foo n0" while it is expected to have type "foo n".
But for B : foo n to be a succ C, C must also be a foo n. Why can't Coq infer this, and how can I fix the definition of bar?
When you match on B, the type system "forgets" that the new n' inside B's type is the same as n. There is a trick to add that information to the context (there are many ways, plugins, etc. but it is good to know how to do it "by hand"). It is called "The convoy pattern" by Adam Chlipala and every coq user must post a question about that once in his/her life (your's truly included).
You make the body be not just a value but a function that takes an additional input with the type n=n' and adds an eq_refl term at the end. This plays well with how Coq's type system can break down terms.
You can either rewrite the A type to change its type from foo n to foo n' with tactics, like this:
Fixpoint bar (n:nat) (A:foo n) (B:foo n) : Prop.
refine (
match B in (foo m) return (n=m -> _) with
| nil => fun _ => False
| #succ n' B' => fun (E : n = n') => bar n' _ B'
end eq_refl).
rewrite E in A.
apply A.
Defined.
or directly with eq_rect
Fixpoint bar {n:nat} (A:foo n) (B:foo n) : Prop :=
match B in (foo m) return (n=m -> _) with
| nil => fun _ => False
| succ B' => fun E => bar (eq_rect _ _ A _ E) B'
end eq_refl.
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.
I am trying to write a function for computing natural division in Coq and I am having some trouble defining it since it is not structural recursion.
My code is:
Inductive N : Set :=
| O : N
| S : N -> N.
Inductive Bool : Set :=
| True : Bool
| False : Bool.
Fixpoint sum (m :N) (n : N) : N :=
match m with
| O => n
| S x => S ( sum x n)
end.
Notation "m + n" := (sum m n) (at level 50, left associativity).
Fixpoint mult (m :N) (n : N) : N :=
match m with
| O => O
| S x => n + (mult x n)
end.
Notation "m * n" := (mult m n) (at level 40, left associativity).
Fixpoint pred (m : N) : N :=
match m with
| O => S O
| S x => x
end.
Fixpoint resta (m:N) (n:N) : N :=
match n with
| O => m
| S x => pred (resta m x)
end.
Notation "m - x" := (resta m x) (at level 50, left associativity).
Fixpoint leq_nat (m : N) (n : N) : Bool :=
match m with
| O => True
| S x => match n with
| O => False
| S y => leq_nat x y
end
end.
Notation "m <= n" := (leq_nat m n) (at level 70).
Fixpoint div (m : N) (n : N) : N :=
match n with
| O => O
| S x => match m <= n with
| False => O
| True => pred (div (m-n) n)
end
end.
As you can see, Coq does not like my function div, it says
Error: Cannot guess decreasing argument of fix.
How can I supply in Coq a termination proof for this function? I can prove that if n>O ^ n<=m -> (m-n) < m.
The simplest strategy in this case is probably to use the Program extension together with a measure. You will then have to provide a proof that the arguments used in the recursive call are smaller than the top level ones according to the measure.
Require Coq.Program.Tactics.
Require Coq.Program.Wf.
Fixpoint toNat (m : N) : nat :=
match m with O => 0 | S n => 1 + (toNat n) end.
Program Fixpoint div (m : N) (n : N) {measure (toNat m)}: N :=
match n with
| O => O
| S x => match m <= n with
| False => O
| True => pred (div (m-n) n)
end
end.
Next Obligation.
(* your proof here *)
Although gallais's answer is definitely the way to go in general, I should point out that we can define division on the natural numbers in Coq as a simple fixpoint. Here, I'm using the definition of nat in the standard library for simplicity.
Fixpoint minus (n m : nat) {struct n} : nat :=
match n, m with
| S n', S m' => minus n' m'
| _, _ => n
end.
Definition leq (n m : nat) : bool :=
match minus n m with
| O => true
| _ => false
end.
Fixpoint div (n m : nat) {struct n} : nat :=
match m with
| O => O
| S m' =>
if leq (S m') n then
match n with
| O => O (* Impossible *)
| S n' => S (div (minus n' m') (S m'))
end
else O
end.
Compute div 6 3.
Compute div 7 3.
Compute div 9 3.
The definition of minus is essentially the one from the standard library. Notice on the second branch of that definition we return n. Thanks to this trick, Coq's termination checker can detect that minus n' m' is structurally smaller than S n', which allows us to perform the recursive call to div.
There's actually an even simpler way of doing this, although a bit harder to understand: you can check whether the divisor is smaller and perform the recursive call in a single step.
(* Divide n by m + 1 *)
Fixpoint div'_aux n m {struct n} :=
match minus n m with
| O => O
| S n' => S (div'_aux n' m)
end.
Definition div' n m :=
match m with
| O => O (* Arbitrary *)
| S m' => div'_aux n m'
end.
Compute div' 6 3.
Compute div' 7 3.
Compute div' 9 3.
Once again, because of the form of the minus function, Coq's termination checker knows that n' in the second branch of div'_aux is a valid argument to a recursive call. Notice also that div'_aux is dividing by m + 1.
Of course, this whole thing relies on a clever trick that requires understanding the termination checker in detail. In general, you have to resort to well-founded recursion, as gallais showed.
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.