I have made the following inductive data type and recursive functions.
Require Coq.Lists.List.
Inductive PairTree : Type :=
| PTLeaf : PairTree
| PTBranch : (nat*nat) -> PairTree -> PairTree -> PairTree.
Fixpoint smush (r m : list nat) : list nat :=
match m with
| nil => r
| h :: t => smush (h :: r) t
end.
I've defined the following function using these, with an auxiliary "gas" parameter so that Coq's termination rules are easily satisfied.
Fixpoint fueled_prefix_part (gas : nat) (r m : list nat) : PairTree :=
match gas with
| 0 => PTLeaf
| S gas' =>
match r with
| nil => PTLeaf
| f :: fs =>
match fs with
| nil => PTLeaf
| f' :: fs' =>
PTBranch (f, f')
(fueled_prefix_part gas' (smush fs' m) nil)
(fueled_prefix_part gas' (f :: fs') (f' :: m))
end
end
end.
However, I wanted to extract actual code from this and run it. Thus, instead of structural recursion on gas, I could get nicer extracted code if instead I could use the following code, since then I could use some other nat-like data type with < (e.g. Haskell Integers).
Require Import Recdef.
Require Export Coq.omega.Omega.
Require Export Coq.Lists.List.
(* Insert definitions of PairTree and smush here. *)
Function fpp' (gas: nat) (r m: list nat) {measure (fun x => x) gas}: PairTree :=
match 0 <? gas with
| false => PTLeaf
| true =>
match r with
| nil => PTLeaf
| f :: fs =>
match fs with
| nil => PTLeaf
| f' :: fs' =>
let gas' := gas - 1 in
PTBranch (f, f')
(fpp' gas' (smush fs' m) nil)
(fpp' gas' (f :: fs') (f' :: m))
end
end
end.
Of course we can't end there; we have to prove that this terminates. The following would appear to prove the termination...
Proof.
intro gas. destruct gas; intros _ _ teq _ _ _ _ _ _.
inversion teq.
omega.
intro gas. destruct gas; intros _ _ teq _ _ _ _ _ _.
inversion teq.
omega.
At this point in ProofGeneral I see no goals in the goal screen, and in the response screen, I see the message
No more subgoals.
(dependent evars:)
So I type in
Defined.
and get the error message
Toplevel input, characters 0-8:
Error: Attempt to save a proof with shelved goals (in proof fpp'_terminate)
What on earth is going on? If I type
Unshelve.
Defined.
I get the same error.
Related
I'm trying to prove correctness of the queue implementation described here:
Inductive queue_type (A : Type) : Type := Queue : list A -> list A -> queue_type A.
Context {A : Type}.
Definition empty_queue : queue_type A := Queue nil nil.
Definition enqueue (queue : queue_type A) (elt : A) : queue_type A :=
match queue with Queue front back => Queue front (elt :: back) end.
Definition dequeue (queue : queue_type A) : queue_type A * option A :=
match queue with
| Queue nil nil => (queue, None)
| Queue (x :: xs) back => (Queue xs back, Some x)
| Queue nil back =>
let front := rev' back in
match front with
| (x :: xs) => (Queue xs nil, Some x)
| nil => (Queue nil nil, None) (* Dead code *)
end
end.
Definition queue_to_list (* last elt in head *) (queue : queue_type A) : list A :=
match queue with Queue front back => (back ++ rev front) end.
Definition queue_length (queue : queue_type A) : nat :=
match queue with Queue front back => List.length front + List.length back end.
Fiddle here
One of the things I'd like to prove involves draining the queue, so I defined this function to do the computation:
Equations queue_dump_all (queue : queue_type A): list A :=
queue_dump_all queue := worker queue nil
where worker (queue': queue_type A) : list A -> list A by wf (queue_length queue') lt :=
worker queue' acc := match (dequeue queue') as deq_res return (deq_res = (dequeue queue')) -> list A with
| (queue'', Some elt) => fun pf => (worker queue'' (elt :: acc))
| _ => fun _=> acc
end _.
Reasoning with queue_dump_all is challenging, so I'm trying to prove this lemma to allow a more direct computation:
Lemma queue_dump_all_to_list: forall (queue: queue_type A), (queue_dump_all queue) = (queue_to_list queue).
I haven't been able to make progress using queue_dump_all_elim, though. I suspect the problem might be the 'manual' matching in worker instead of relying on Equation's pattern matching construct, but I had trouble with the proof of well formedness that way. Is there a way to push this proof forward?
(Originally written using Program Fixpoint but I couldn't get this answer to work either).
Here is a solution following your initial try:
https://x80.org/collacoq/amugunalib.coq
The moral is: do not use match ... with end eq_refl constructs but rather rely on with and the inspect pattern, Equations will then avoid getting you into dependent rewrite hell.
From Equations Require Import Equations.
Require Import List.
Set Implicit Arguments.
Set Asymmetric Patterns.
Inductive queue_type (A : Type) : Type := Queue : list A -> list A -> queue_type A.
Context {A : Type}.
Definition empty_queue : queue_type A := Queue nil nil.
Definition enqueue (queue : queue_type A) (elt : A) : queue_type A :=
match queue with Queue front back => Queue front (elt :: back) end.
Equations dequeue (queue : queue_type A) : queue_type A * option A :=
| Queue nil nil => (Queue nil nil, None);
| Queue (x :: xs) back => (Queue xs back, Some x);
| Queue nil back with rev' back := {
| (x :: xs) => (Queue xs nil, Some x);
| nil => (Queue nil nil, None) (* Dead code *) }.
Definition queue_to_list (* last elt in head *) (queue : queue_type A) : list A :=
match queue with Queue front back => (back ++ rev front) end.
Definition queue_length (queue : queue_type A) : nat :=
match queue with Queue front back => List.length front + List.length back end.
Axiom cheat : forall {A}, A.
Lemma dequeue_queue_to_list (q : queue_type A) :
let (l, r) := dequeue q in queue_to_list q =
match r with Some x => queue_to_list l ++ (cons x nil) | None => nil end.
Proof.
funelim (dequeue q); unfold queue_to_list; auto.
- cbn. now rewrite app_assoc.
- cbn. apply cheat. (* contradiction *)
- cbn. apply cheat. (* algebra on rev, etc *)
Qed.
Definition inspect {A} (a : A) : { b : A | a = b } := (exist _ a eq_refl).
Equations queue_dump_all (queue : queue_type A): list A :=
queue_dump_all queue := worker queue nil
where worker (queue': queue_type A) : list A -> list A by wf (queue_length queue') lt :=
worker queue' acc with inspect (dequeue queue') := {
| #exist (queue'', Some elt) eq =>
(worker queue'' (elt :: acc));
| _ => acc }.
Next Obligation.
apply cheat.
Defined.
Lemma app_cons_nil_app {A} (l : list A) a l' : (l ++ a :: nil) ++ l' = l ++ a :: l'.
Proof.
now rewrite <- app_assoc; cbn.
Qed.
Lemma queue_dump_all_to_list: forall (queue: queue_type A), (queue_dump_all queue) = (queue_to_list queue).
Proof.
intros q.
apply (queue_dump_all_elim (fun q l => l = queue_to_list q)
(fun q queue' acc res =>
res = queue_to_list queue' ++ acc)); auto.
- intros.
now rewrite app_nil_r in H.
- intros. rewrite H; clear H.
generalize (dequeue_queue_to_list queue').
destruct (dequeue queue').
clear Heq. noconf e.
intros ->. now rewrite app_cons_nil_app.
- intros.
generalize (dequeue_queue_to_list queue').
destruct (dequeue queue').
clear Heq. noconf e. cbn.
now intros ->.
Qed.
The problem with the well founded recursion is that it uses the proof terms for computing. This was readily apparent when attempting to compute with queue_dump_all, which required rewriting and making some lemmas transparent and being careful with the proof for the hole. (this blogpost helped me figure this one out).
The dependency on proof terms, however, made it difficult to do any reasoning with the unfolded term. My first attempt was to reify the measure and move the proof into a signature type:
Equations queue_dump_all: queue_type A -> list A :=
queue_dump_all qu := worker (exist (fun q => queue_length q = (queue_length queue)) qu eq_refl) nil
where worker (len: nat) (q: {q: queue_type A | queue_length q = len}) (acc: list A): list A :=
#worker 0 _ acc := acc;
#worker (S len') queue acc with (dequeue queue.val).2 := {
| Some elt := (worker (exist (fun q=> queue_length q = len') (dequeue (proj1_sig queue)).1 _) (elt :: acc));
| _ := acc
}.
This was easier to prove and actually computed since the proof terms could now easily be removed. However, the sig objects made the resulting equations difficult to work with. (Lots of "Dependent type error in rewrite of ..." like in this question).
The solution was finally moving to a weak specification like this:
Equations drain' (queue : queue_type A): option (list A) :=
drain' queue := worker (S (queue_length queue)) queue nil
where worker (gas: nat) (q: queue_type A) (acc: list A): option (list A) :=
#worker 0 _ _ := None;
#worker (S gas') queue acc with (dequeue queue).2 := {
| Some elt := worker gas' (dequeue queue).1 (elt :: acc);
| _ := Some acc
}.
Lemma drain_completes: forall q, drain' q <> None. ... Qed.
Definition queue_drain (queue: queue_type A): list A :=
match drain' queue as res return (drain' queue = res -> list A) with
| Some drained => fun pf => drained
| None => fun pf => False_rect _ (drain_completes pf)
end eq_refl.
Moving the proof terms out of the computation makes it much easier to reason with the lemmas generated by Equation with freedom to rewrite.
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.
Consider the following pair of mutually recursive Coq data types, which represent a Forest of nonempty Trees. Each Branch of a Tree holds an extra boolean flag, which we can extract with isOK.
Inductive Forest a : Type
:= Empty : Forest a
| WithTree : Tree a -> Forest a -> Forest a
with Tree a : Type
:= Branch : bool -> a -> Forest a -> Tree a.
Arguments Empty {_}.
Arguments WithTree {_} _ _.
Arguments Branch {_} _ _ _.
Definition isOK {a} (t : Tree a) : bool :=
match t with
| Branch ok _ _ => ok
end.
Now, if we ignore this boolean flag, we can write a pair of mapping functions to apply a function to every value in a Forest or a Tree, and this works fine:
Fixpoint mapForest_always {a} (f : a -> a) (ts0 : Forest a) {struct ts0} : Forest a :=
match ts0 with
| Empty => Empty
| WithTree t ts => WithTree (mapTree_always f t) (mapForest_always f ts)
end
with mapTree_always {a} (f : a -> a) (t : Tree a) {struct t} : Tree a :=
match t with
| Branch ok x ts => Branch ok (f x) (mapForest_always f ts)
end.
However, suppose the boolean represents some validity check, which would be more complicated in real code. So we check the boolean first, and only actually recurse if necessary. This means we have three mutually recursive functions, but one of them is just handing the work along. Unfortunately, this doesn’t work:
Fail Fixpoint mapForest_bad {a} (f : a -> a) (ts0 : Forest a) {struct ts0} : Forest a :=
match ts0 with
| Empty => Empty
| WithTree t ts => WithTree (mapTree_bad f t) (mapForest_bad f ts)
end
with mapTree_bad {a} (f : a -> a) (t : Tree a) {struct t} : Tree a :=
if isOK t
then mapOKTree_bad f t
else t
with mapOKTree_bad {a} (f : a -> a) (t : Tree a) {struct t} : Tree a :=
match t with
| Branch ok x ts => Branch ok (f x) (mapForest_bad f ts)
end.
The problem is that mapTree_bad calls into mapOKTree_bad on an argument that isn’t actually smaller.
Except… all mapOKTree_bad is doing is an extra step after some preprocessing. This will always terminate, but Coq can’t see that. To persuade the termination checker, we can instead define mapOKTree_good, which is the same but is a local let-binding; then, the termination checker will see through the let-binding and allow us to define mapForest_good and mapTree_good. If we want to get mapOKTree_good, we can just use a plain old definition after we’ve defined the mutually recursive functions, which just has the same body as the let-binding:
Fixpoint mapForest_good {a} (f : a -> a) (ts0 : Forest a) {struct ts0} : Forest a :=
match ts0 with
| Empty => Empty
| WithTree t ts => WithTree (mapTree_good f t) (mapForest_good f ts)
end
with mapTree_good {a} (f : a -> a) (t : Tree a) {struct t} : Tree a :=
let mapOKTree_good {a} (f : a -> a) (t : Tree a) : Tree a :=
match t with
| Branch ok x ts => Branch ok (f x) (mapForest_good f ts)
end in
if isOK t
then mapOKTree_good f t
else t.
Definition mapOKTree_good {a} (f : a -> a) (t : Tree a) : Tree a :=
match t with
| Branch ok x ts => Branch ok (f x) (mapForest_good f ts)
end.
This works, but it’s not pretty. Is there any way to convince Coq’s termination checker to accept the _bad variants, or is the _good trick the best I’ve got? A command that does work for me, such as Program Fixpoint or Function, is a totally reasonable solution as well.
Very partial answer: we can refactor the two definitions of mapOKTree_good with an intermediate definition parameterized by mapForest_good just before it is defined.
Definition mapOKTree_good_ {a} mapForest_good
(f : a -> a) (t : Tree a) : Tree a :=
match t with
| Branch ok x ts => Branch ok (f x) (mapForest_good f ts)
end.
Fixpoint mapForest_good {a} (f : a -> a) (ts0 : Forest a) {struct ts0} : Forest a :=
match ts0 with
| Empty => Empty
| WithTree t ts => WithTree (mapTree_good f t) (mapForest_good f ts)
end
with mapTree_good {a} (f : a -> a) (t : Tree a) {struct t} : Tree a :=
if isOK t
then mapOKTree_good_ mapForest_good f t
else t.
Definition mapOKTree_good {a} := #mapOKTree_good_ a mapForest_good.
Consider this example:
Inductive T :=
| foo : T
| bar : nat -> T -> T.
Fixpoint evalT (t:T) {struct t} : nat :=
match t with
| foo => 1
| bar n x => evalBar x n
end
with evalBar (x:T) (n:nat) {struct n} : nat :=
match n with
| O => 0
| S n' => (evalT x) + (evalBar x n')
end.
Coq rejects it with an error: Recursive call to evalBar has principal argument equal to "n" instead of "x".
I understand that termination checker got confused by two unrelated inductive types (T and nat). However, it looks like the function I am trying to define will indeed terminate. How can I make Coq accept it?
Another solution is to use a nested fixpoint.
Fixpoint evalT (t:T) {struct t} : nat :=
match t with
| foo => 1
| bar n x => let fix evalBar n {struct n} :=
match n with
| 0 => 0
| S n' => Nat.add (evalT x) (evalBar n')
end
in evalBar n
end.
The important point is to remove the argument x from evalBar. Thus the recursive call to evalT is done on the x from bar n x, not the x given as an argument to evalBar, and thus the termination checker can validate the definition of evalT.
This is the same idea that makes the version with nat_rec proposed in another answer work.
One solution I found is to use nat_rec instead of evalBar:
Fixpoint evalT (t:T) {struct t} : nat :=
match t with
| foo => 1
| bar n x => #nat_rec _ 0 (fun n' t' => (evalT x) + t') n
end.
It works but I wish I could hide nat_rec under evalBar definition to hide details. In my real project, such construct is used several times.
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.