I am trying to proof an induction principle in Coq. Due to the definition of the data structure it is obligatory to show this principle via two nested inductions. The outer induction is done via the Fixpoint construct and the inner induction is done with principle list_ind.
The problem occuring is now that the induction argument of the inner induction is the result of a function, namely dfs t.
Inductive SearchTree (A : Type) : Type :=
| empty : SearchTree A
| leaf : A -> SearchTree A
| choice : SearchTree A -> SearchTree A -> SearchTree A.
Fixpoint dfs (A : Type) (t: SearchTree A) : list A :=
match t with
| empty => nil
| leaf x => cons x nil
| choice t1 t2 => app (dfs t1) (dfs t2)
end.
In the inner induction step I need to be able to apply the outer induction hypothesis to the first element of dfs t. But: when doing induction on dfs t this is not possible as it leads to an ill-formed recursion.
In my eyes the "normal" approach would be to do induction on t and simplification, but in case t = choice t1 t2 this always leads back to the initial problem as dfs (choice t1 t2) only reduces to dfs t1 ++ dfs t2.
Does somebody have an suggestion how to go on with this proof?
EDIT: Thought it might be a little much to show the code, but here it is:
Require Import Setoid.
Require Import Coq.Lists.List.
Set Implicit Arguments.
Set Contextual Implicit.
Section list.
Section listEquality.
Variable A : Type.
Variable eqA : A -> A -> Prop.
Inductive EqL : list A -> list A -> Prop :=
| EqL_nil : EqL nil nil
| EqL_cons : forall (x y : A) (xs ys : list A),
eqA x y ->
EqL xs ys ->
EqL (cons x xs) (cons y ys).
End listEquality.
End list.
Section SearchTree.
Inductive SearchTree (A : Type) : Type :=
| empty : SearchTree A
| leaf : A -> SearchTree A
| choice : SearchTree A -> SearchTree A -> SearchTree A.
Fixpoint dfs (A : Type) (t: SearchTree A) : list A :=
match t with
| empty => nil
| leaf x => cons x nil
| choice t1 t2 => app (dfs t1) (dfs t2)
end.
Section DFSEquality.
Variable A : Type.
Variable eqA : relation A.
Definition EqDFS (t1 t2: SearchTree A) : Prop :=
EqL eqA (dfs t1) (dfs t2).
End DFSEquality.
End SearchTree.
Section List.
Inductive List A :=
| Nil : List A
| Cons : SearchTree A -> SearchTree (List A) -> List A.
End List.
Section EqND.
Variable A : Type.
Variable eqA : relation A.
Inductive EqND : List A -> List A -> Prop :=
| Eq_Nil : EqND Nil Nil
| Eq_Cons : forall tx ty txs tys,
EqDFS eqA tx ty ->
EqDFS EqND txs tys ->
EqND (Cons tx txs) (Cons ty tys).
End EqND.
Section EqNDInd.
Variable A : Type.
Variable eqA : relation A.
Variable P : List A -> List A -> Prop.
Hypothesis BC : P Nil Nil.
Hypothesis ST: forall mx my mxs mys,
EqDFS eqA mx my
-> EqDFS (fun xs ys => EqND eqA xs ys /\ P xs ys) mxs mys
-> P (Cons mx mxs) (Cons my mys).
Fixpoint IND (xs ys : List A) { struct xs } : EqND eqA xs ys -> P xs ys.
Proof.
intro eq.
destruct xs,ys.
+ exact BC.
+ inversion eq.
+ inversion eq.
+ inversion eq. subst. apply ST.
++ exact H2.
++ unfold EqDFS in *.
generalize dependent (dfs s2).
induction (dfs s0).
+++ intros. inversion H4. constructor.
+++ intros. inversion H4. subst. constructor.
++++ split.
* exact H1.
* apply IND. exact H1. (* Guarded. *)
++++ clear IND. firstorder.
Admitted.
End EqNDInd.
The problem occurs proving IND, the Guarded. commented out fails.
To use nested recursion you have to resort to the raw fix construct using the "fix 1" tactic for example. The induction principles won't give you the right recursive calls. Beware that inversions might do rewritings that confuse the guard checker.
Actually, if you want the "nested" fixpoint to not be on a subterm of the original list but on [dfs t] then it's no longer a structural recursion and you need to justify the recursion using well-founded recursion. I have a similar example on rose trees where well-founded nested recursion is used.
There are two problems in your attempt:
The way you wrote IND prevent the recursive argument to be eq: EqND eqA xs ys, while this would be the natural one.
As remarked by #Matthieu Sozeau, the multiple inversions introduce noise.
Surprisingly, the proof is quite short.
Here is my solution:
Fixpoint IND (xs ys : List A) (eq: EqND eqA xs ys) : P xs ys.
Proof.
destruct eq.
- assumption.
- apply ST.
+ assumption.
+ unfold EqDFS in H0 |- *. induction H0.
* constructor.
* constructor.
-- split.
++ assumption.
++ apply IND. assumption.
-- assumption.
Qed.
Related
I defined a type of s-expressions and it's printing functions.
Inductive sexp : Set :=
K : string -> (list sexp) -> sexp
.
Fixpoint sexpprint (s:sexp) : list string :=
match s with
K n l => ["("%string]++[n]++(concat (map sexpprint l))++[")"%string]
end.
(Yes, I understand it can be just string, not the list of strings, but Coq have small amount of theorems for working with strings, but a big amount for working with lists.)
(* more usual function
Fixpoint sexpprint (s:sexp) :string :=
match s with
K n l => ("(":string)++n++(String.concat "" (map sexpprint l))++")"
end.
*)
And I've got stuck trying to prove this theorem:
Theorem sexpprint_inj s1 s2:
sexpprint s1 = sexpprint s2 -> s1 = s2.
Maybe there are some sources which can help me to plan the theorem's proof? (books/articles/codes) How to prove it?
(Maybe I need a special kind of inductive principle, could you formulate its statement?)
Also I defined depth function, it may somehow help
Fixpoint depth (s:sexp) : nat :=
match s with
K n l =>
(match l with
nil => 0
| _ => S (list_max (map depth l))
end)
end.
Thanks!
p.s. some additional thoughts:
Theorem depth_decr n l s m:
depth (K n l) = m
->
In s l
->
depth s < m
.
Proof.
Admitted.
Theorem step_lem (m:nat) :
(forall s1 s2,
depth s1 < m ->
depth s2 < m ->
sexpprint s1 = sexpprint s2 -> s1 = s2
) ->
(forall s1 s2,
depth s1 = m ->
depth s2 = m ->
sexpprint s1 = sexpprint s2 -> s1 = s2
).
Proof.
intros H s1 s2 Q1 Q2 E.
destruct s1 as [n1 l1], s2 as [n2 l2].
simpl in E.
inversion E as [E1].
apply (app_inv_tail) in H0.
Search "concat".
cut (l1=l2).
intros []; reflexivity.
Search "In".
induction l1, l2.
+ trivial.
+ simpl in H0.
destruct s.
unfold sexpprint in H0.
simpl in H0.
inversion H0.
+ simpl in H0.
destruct a.
unfold sexpprint in H0.
simpl in H0.
inversion H0.
+ admit.
Admitted.
p.p.s. I feel like the main obstacle is performing induction on two lists.
The type sexp is an example of a nested inductive type, where one of the recursive occurrences appears inside of another induction. Such types are hard to work with in Coq, because the induction principles that it generates by default are not useful. However, you can fix this issue by writing down your own induction principle by hand. Here is one possibility:
Require Import Coq.Lists.List Coq.Strings.String.
Import ListNotations.
Unset Elimination Schemes.
Inductive sexp : Type :=
| K : string -> list sexp -> sexp.
Set Elimination Schemes.
Definition tuple (T : sexp -> Type) (es : list sexp) :=
fold_right (fun e R => T e * R)%type unit es.
Definition sexp_rect
(T : sexp -> Type)
(H : forall s es, tuple T es -> T (K s es)) :
forall e, T e :=
fix outer (e : sexp) : T e :=
match e with
| K s es =>
let fix inner (es : list sexp) : tuple T es :=
match es return tuple T es with
| [] => tt
| e :: es => (outer e, inner es)
end in
H s es (inner es)
end.
Definition sexp_ind (T : sexp -> Prop) := sexp_rect T.
With this induction principle, it is now possible to prove your lemma (exercise!), but you will need to generalize its statement a bit.
For a deeper discussion about these nested inductives, you can have a look at CPDT.
I'm very new to Coq. Suppose under some hypothesis I want to prove l1 = l2, both of which are lists. I wonder what is a general strategy if I want to prove it inductively.
I don't know of any way to do induction on l1 and l2 at the same time. If I do induction first on l1, then I'll end up having to prove l1 = l2 under hypothesis t1 = l2, where t1 is tail of l1, which is obviously false.
Usually it depends on what kind of hypothesis you have.
However, as a general principle, if you want to synchronise two lists when doing induction on one, you have to generalise over the other.
induction l in l' |- *.
or
revert l'.
induction l.
It might also be that you have some hypothesis on both l and l' on which you can do induction instead.
For instance, the Forall2 predicate synchronises the two lists:
Inductive Forall2 (A B : Type) (R : A -> B -> Prop) : list A -> list B -> Prop :=
| Forall2_nil : Forall2 R [] []
| Forall2_cons : forall (x : A) (y : B) (l : list A) (l' : list B), R x y -> Forall2 R l l' -> Forall2 R (x :: l) (y :: l')
If you do induction on this, it will destruct both lists at the same time.
Coq, unlike many others, accepts an optional explicit parameter,which can be used to indicate the decreasing structure of a fixpoint definition.
From Gallina specification, 1.3.4,
Fixpoint ident params {struct ident0 } : type0 := term0
defines the syntax. but from it, we've known that it must be an identifier, instead of a general measure.
However, in general, there are recursive functions, that the termination is not quite obvious,or it in fact is, but just difficult for the termination checker to find a decreasing structure. For example, following program interleaves two lists,
Fixpoint interleave (A : Set) (l1 l2 : list A) : list A :=
match l1 with
| [] => []
| h :: t => h :: interleave l2 t
end
This function clearly terminates, while Coq just couldn't figure it out. The reason is neither l1 nor l2 are decreasing every cycle. But what if we consider a measure, defined to be length l1 + length l2? Then this measure clearly decreases every recursion.
So my question is, in the case of sophisticated situation, where code is not straightforward to be organized in a termination checkable way, how do you educate coq and convince it to accept the fixpoint definition?
You have multiple options and all of them boil down to structural recursion in the end.
Preamble
From Coq Require Import List.
Import ListNotations.
Set Implicit Arguments.
Structural recursion
Sometimes you can reformulate your algorithm in a structurally recursive way:
Fixpoint interleave1 {A} (l1 l2 : list A) {struct l1} : list A :=
match l1, l2 with
| [], _ => l2
| _, [] => l1
| h1 :: t1, h2 :: t2 => h1 :: h2 :: interleave1 t1 t2
end.
Incidentally, in some cases you can use a trick with nested fixes -- see this definition of Ackermann function (it wouldn't work with just Fixpoint).
Program Fixpoint
You can use Program Fixpoint mechanism which lets you write your program naturally and later prove that it always terminates.
From Coq Require Import Program Arith.
Program Fixpoint interleave2 {A} (l1 l2 : list A)
{measure (length l1 + length l2)} : list A :=
match l1 with
| [] => l2
| h :: t => h :: interleave2 l2 t
end.
Next Obligation. simpl; rewrite Nat.add_comm; trivial with arith. Qed.
Function
Another option is to use the Function command which can be somewhat limited compared to Program Fixpoint. You can find out more about their differences here.
From Coq Require Recdef.
Definition sum_len {A} (ls : (list A * list A)) : nat :=
length (fst ls) + length (snd ls).
Function interleave3 {A} (ls : (list A * list A))
{measure sum_len ls} : list A :=
match ls with
| ([], _) => []
| (h :: t, l2) => h :: interleave3 (l2, t)
end.
Proof.
intros A ls l1 l2 h t -> ->; unfold sum_len; simpl; rewrite Nat.add_comm; trivial with arith.
Defined.
Equations plugin
This is an external plugin which addresses many issues with defining functions in Coq, including dependent types and termination.
From Equations Require Import Equations.
Equations interleave4 {A} (l1 l2 : list A) : list A :=
interleave4 l1 l2 by rec (length l1 + length l2) lt :=
interleave4 nil l2 := l2;
interleave4 (cons h t) l2 := cons h (interleave4 l2 t).
Next Obligation. rewrite Nat.add_comm; trivial with arith. Qed.
The code above works if you apply this fix.
Fix / Fix_F_2 combinators
You can learn more about this (manual) approach if you follow the links from this question about mergeSort function. By the way, the mergeSort function can be defined without using Fix if you apply the nested fix trick I mentioned earlier. Here is a solution which uses Fix_F_2 combinator since we have two arguments and not one like mergeSort:
Definition ordering {A} (l1 l2 : list A * list A) : Prop :=
length (fst l1) + length (snd l1) < length (fst l2) + length (snd l2).
Lemma ordering_wf' {A} : forall (m : nat) (p : list A * list A),
length (fst p) + length (snd p) <= m -> Acc (#ordering A) p.
Proof.
unfold ordering; induction m; intros p H; constructor; intros p'.
- apply Nat.le_0_r, Nat.eq_add_0 in H as [-> ->].
intros contra%Nat.nlt_0_r; contradiction.
- intros H'; eapply IHm, Nat.lt_succ_r, Nat.lt_le_trans; eauto.
Defined.
Lemma ordering_wf {A} : well_founded (#ordering A).
Proof. now red; intro ; eapply ordering_wf'. Defined.
(* it's in the stdlib but unfortunately opaque -- this blocks evaluation *)
Lemma destruct_list {A} (l : list A) :
{ x:A & {tl:list A | l = x::tl} } + { l = [] }.
Proof.
induction l as [|h tl]; [right | left]; trivial.
exists h, tl; reflexivity.
Defined.
Definition interleave5 {A} (xs ys : list A) : list A.
refine (Fix_F_2 (fun _ _ => list A)
(fun (l1 l2 : list A)
(interleave : (forall l1' l2', ordering (l1', l2') (l1, l2) -> list A)) =>
match destruct_list l1 with
| inright _ => l2
| inleft pf => let '(existT _ h (exist _ tl eq)) := pf in
h :: interleave l2 tl _
end) (ordering_wf (xs,ys))).
Proof. unfold ordering; rewrite eq, Nat.add_comm; auto.
Defined.
Evaluation tests
Check eq_refl : interleave1 [1;2;3] [4;5;6] = [1;4;2;5;3;6].
Check eq_refl : interleave2 [1;2;3] [4;5;6] = [1;4;2;5;3;6].
Check eq_refl : interleave3 ([1;2;3], [4;5;6]) = [1;4;2;5;3;6].
Fail Check eq_refl : interleave4 [1;2;3] [4;5;6] = [1;4;2;5;3;6]. (* Equations plugin *)
Check eq_refl : interleave5 [1;2;3] [4;5;6] = [1;4;2;5;3;6].
Exercise: what happens with this last check if you comment out destruct_list lemma?
You can use something called a measure instead of a structural argument for termination. For this, I believe you have to use the Program Fixpoint mechanism, which is a little involved and will make your proofs look uglier (because it generates a structural recursion out of the proof that you provide, so that the function you will actually use is not quite the function you wrote).
Details here:
https://coq.inria.fr/refman/program.html
It also seems like something called Equations can deal with measures?
cf. http://mattam82.github.io/Coq-Equations/examples/RoseTree.html
https://www.irif.fr/~sozeau/research/coq/equations.en.html
I am trying to proof that the application of an empty Substitution on a term is equal to the given term.
Here is the code:
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import Coq.Arith.EqNat.
Require Import Recdef.
Require Import Omega.
Import ListNotations.
Set Implicit Arguments.
Inductive Term : Type :=
| Var : nat -> Term
| Fun : string -> list Term -> Term.
Definition Subst : Type := list (nat*Term).
Definition maybe{X Y: Type} (x : X) (f : Y -> X) (o : option Y): X :=
match o with
|None => x
|Some a => f a
end.
Fixpoint lookup {A B : Type} (eqA : A -> A -> bool) (kvs : list (A * B)) (k : A) : option B :=
match kvs with
|[] => None
|(x,y) :: xs => if eqA k x then Some y else lookup eqA xs k
end.
I am trying to proof some properties of this function.
Fixpoint apply (s : Subst) (t : Term) : Term :=
match t with
| Var x => maybe (Var x) id (lookup beq_nat s x )
| Fun f ts => Fun f (map (apply s ) ts)
end.
Lemma empty_apply_on_term:
forall t, apply [] t = t.
Proof.
intros.
induction t.
reflexivity.
I am stuck after the reflexivity. I wanted to do induction on the list build in a term but if i do so i'ĺl get stuck in a loop.
i will appreciate any help.
The problem is that the automatically generated inductive principle for the Term type is too weak, because it has another inductive type list inside it (specifically, list is applied to the very type being constructed). Adam Chlipala's CPDT gives a good explanation of what's going on, as well as an example of how to manually build a better inductive principle for such types in the inductive types chapter. I've adapted his example nat_tree_ind' principle for your Term inductive, using the builtin Forall rather than a custom definition. With it, your theorem becomes easy to prove:
Section Term_ind'.
Variable P : Term -> Prop.
Hypothesis Var_case : forall (n:nat), P (Var n).
Hypothesis Fun_case : forall (s : string) (ls : list Term),
Forall P ls -> P (Fun s ls).
Fixpoint Term_ind' (tr : Term) : P tr :=
match tr with
| Var n => Var_case n
| Fun s ls =>
Fun_case s
((fix list_Term_ind (ls : list Term) : Forall P ls :=
match ls with
| [] => Forall_nil _
| tr'::rest => Forall_cons tr' (Term_ind' tr') (list_Term_ind rest)
end) ls)
end.
End Term_ind'.
Lemma empty_apply_on_term:
forall t, apply [] t = t.
Proof.
intros.
induction t using Term_ind'; simpl; auto.
f_equal.
induction H; simpl; auto.
congruence.
Qed.
This is a typical trap for beginners. The problem is that your definition of Term has a recursive occurrence inside another inductive type -- in this case, list. Coq does not generate a useful inductive principle for such types, unfortunately; you have to program your own. Adam Chlipala's CDPT has a chapter on inductive types that describes the problem. Just look for "nested inductive types".
I have a function count that counts how many times a given predicate is provable when applied to elements of a list. It is defined as follows:
Parameter T : Type.
Parameter dec: forall (p: T -> Prop) (w: T), {p w} + {~ (p w)}.
Fixpoint count (p: T -> Prop) (l: list T) := match l with
| nil => 0
| (cons head tail) => if (dec p head) then (1 + (count p tail)) else (count p tail)
end.
I then use this function to state lemmas like the following:
Parameter a b c: T.
Parameter q: T -> Prop.
Axiom Aa: (q a).
Axiom Ab: (q b).
Axiom Ac: ~ (q c).
Lemma example: (count q (cons a (cons b (cons c nil)))) = 2.
My proofs of such lemmas tend to be quite tedious:
Lemma example: (count q (cons a (cons b (cons c nil)))) = 2.
Proof.
unfold count.
assert (q a); [apply Aa| auto].
assert (q b); [apply Ab| auto].
assert (~ (q c)); [apply Ac| auto].
destruct (dec q a); [auto | contradiction].
destruct (dec q b); [auto | contradiction].
destruct (dec q c); [contradiction | auto].
Qed.
What can I do to automate such tedious proofs that involve computation with my count function?
This is typically the kind of cases where you are better off proving things by reflection. See how things go smoothly (of course I modified a bit your example to avoid all these axioms):
Require Import List.
Import ListNotations.
Fixpoint count {T : Type} (p : T -> bool) (l : list T) :=
match l with
| [] => 0
| h :: t => if p h then S (count p t) else (count p t)
end.
Inductive T := a | b | c.
Definition q x :=
match x with
| a => true
| b => true
| c => false
end.
Lemma example: (count q [a; b; c]) = 2.
Proof.
reflexivity.
Qed.
I realize that your definition of count was taking a propositional predicate on type T (but with the assumption that all predicates on type T are decidable) and instead I propose to define count to take a boolean predicate. But you may realize that having a decidable propositional predicate or having a boolean predicate is actually equivalent.
E.g. from your axioms, I can define a function which transform any propositional predicate into a boolean one:
Parameter T : Type.
Parameter dec: forall (p: T -> Prop) (w: T), {p w} + {~ (p w)}.
Definition prop_to_bool_predicate (p : T -> Prop) (x : T) : bool :=
if dec p x then true else false.
Of course, because there are axioms involved in your example, it won't actually be possible to compute with the boolean predicate. But I'm assuming that you put all these axioms for the purpose of the example and that your actual application doesn't have them.
Answer to your comment
As I told you, as soon as you have defined some function in terms of an axiom (or of a Parameter since this is the same thing), there is no way you can compute with it anymore.
However, here is a solution where the decidability of propositional predicate p is a lemma instead. I ended the proof of the lemma with Defined instead of Qed to allow computing with it (otherwise, it wouldn't be any better than an axiom). As you can see I also redefined the count function to take a predicate and a proof of its decidability. The proof by reflection still works in that case. There is no bool but it is strictly equivalent.
Require Import List.
Import ListNotations.
Fixpoint count {T : Type}
(p : T -> Prop) (dec : forall (w: T), {p w} + {~ (p w)}) (l : list T) :=
match l with
| [] => 0
| h :: t => if dec h then S (count p dec t) else (count p dec t)
end.
Inductive T := a | b | c.
Definition p x := match x with | a => True | b => True | c => False end.
Lemma dec_p: forall (w: T), {p w} + {~ (p w)}.
Proof.
intros []; simpl; auto.
Defined.
Lemma example2: (count p dec_p [a; b; c]) = 2. Proof. reflexivity. Qed.
Let's create our custom hint database and add your axioms there:
Hint Resolve Aa : axiom_db.
Hint Resolve Ab : axiom_db.
Hint Resolve Ac : axiom_db.
Now, the firstorder tactic can make use of the hint database:
Lemma example: count q (cons a (cons b (cons c nil))) = 2.
Proof.
unfold count.
destruct (dec q a), (dec q b), (dec q c); firstorder with axiom_db.
Qed.
We can automate our solution using the following piece of Ltac:
Ltac solve_the_probem :=
match goal with
|- context [if dec ?q ?x then _ else _] =>
destruct (dec q x);
firstorder with axioms_db;
solve_the_probem
end.
Then, unfold count; solve_the_probem. will be able to prove the lemma.