Second order unification with rewrite - coq

I have a lemma such as the following, with a higher-order parameter:
Require Import Coq.Lists.List.
Lemma map_fst_combine:
forall A B C (f : A -> C) (xs : list A) (ys : list B),
length xs = length ys ->
map (fun p => f (fst p)) (combine xs ys) = map f xs.
Proof.
induction xs; intros.
* destruct ys; try inversion H.
simpl. auto.
* destruct ys; try inversion H.
simpl. rewrite IHxs; auto.
Qed.
I would like to use this as with rewrite. It works if I specify f directly:
Parameter list_fun : forall {A}, list A -> list A.
Parameter length_list_fun : forall A (xs : list A), length (list_fun xs) = length xs.
Lemma this_works:
forall (xs : list bool),
map (fun p => negb (negb (fst p))) (combine xs (list_fun xs)) = xs.
Proof.
intros.
rewrite map_fst_combine with (f := fun x => negb (negb x))
by (symmetry; apply length_list_fun).
Admitted.
but I would really like not having to do that (in my case, I would like to use this lemma as part of a autorewrite set). But
Lemma this_does_not:
forall (xs : list bool),
map (fun p => negb (negb (fst p))) (combine xs (list_fun xs)) = xs.
Proof.
intros.
rewrite map_fst_combine.
fails with
(*
Error:
Found no subterm matching "map (fun p : ?M928 * ?M929 => ?M931 (fst p))
(combine ?M932 ?M933)" in the current goal.
*)
Am I expecting too much here, or is there a way to make this work?

Let's define the composition operator (or you might want to reuse the one defined in Coq.Program.Basics):
Definition comp {A B C} (g : B -> C) (f : A -> B) :=
fun x : A => g (f x).
Infix "∘" := comp (at level 90, right associativity).
Now, let's formulate the map_fst_combine lemma in terms of composition:
Lemma map_fst_combine:
forall A B C (f : A -> C) (xs : list A) (ys : list B),
length xs = length ys ->
map (f ∘ fst) (combine xs ys) = map f xs.
Admitted. (* the proof remains the same *)
Now we need some helper lemmas for autorewrite:
Lemma map_comp_lassoc A B C D xs (f : A -> B) (g : B -> C) (h : C -> D) :
map (fun x => h (g (f x))) xs = map ((h ∘ g) ∘ f) xs.
Proof. reflexivity. Qed.
Lemma map_comp_lassoc' A B C D E xs (f : A -> B) (g : B -> C) (h : C -> D) (i : D -> E) :
map (i ∘ (fun x => h (g (f x)))) xs = map ((i ∘ h) ∘ (fun x => g (f x))) xs.
Proof. reflexivity. Qed.
With the following hints
Hint Rewrite map_comp_lassoc map_comp_lassoc' map_fst_combine : mapdb.
we are able to do automatic rewrites and get rid of fst and combine:
Lemma autorewrite_works xs :
map (fun p => negb (negb (fst p))) (combine xs (list_fun xs)) = xs.
Proof.
autorewrite with mapdb.
(* 1st subgoal: map (negb ∘ negb) xs = xs *)
Admitted.
Lemma autorewrite_works' xs :
map (fun p => negb (negb (negb (negb (fst p))))) (combine xs (list_fun xs)) = xs.
Proof.
autorewrite with mapdb.
(* 1st subgoal: map (((negb ∘ negb) ∘ negb) ∘ negb) xs = xs *)
Admitted.

Related

Append and Split is same as doing nothing

I want to prove following lemmas.
Lemma AppendAndSplit {n m}(e:Euc n) (f:Euc m): # (e +++ f) = (e, f).
Proof.
induction e.
reflexivity.
remember (r:::e).
Admitted.
Lemma SplitRule {n m}(e:Euc (n+m)) : (fst (# e)) +++ (snd (# e)) = e.
Proof.
induction n.
reflexivity.
Admitted.
# and +++ are notations of EucAppend and Split_Euc.
I can feel that these hold, but I don't know how prove them.
Please tell me some techniques.
(* There are codes needed below *)
Require Import Coq.Reals.Reals.
Inductive Euc:nat -> Type:=
|RO : Euc 0
|Rn : forall {n:nat}, R -> Euc n -> Euc (S n).
Notation "[ ]" := RO.
Notation "[ r1 , .. , r2 ]" := (Rn r1 .. ( Rn r2 RO ) .. ).
Infix ":::" := Rn (at level 60, right associativity).
Fixpoint EucAppend {n m} (e:Euc n) (f:Euc m) :Euc (n+m):=
match e with
|[] => f
|e' ::: es => e' ::: (EucAppend es f)
end.
Infix "+++" := EucAppend (at level 60, right associativity).
Fixpoint split_Euc {n m : nat} (xi : Euc (n + m)) : Euc n ∧ Euc m.
Proof.
destruct n as [ | n].
- exact (RO, xi).
- inversion_clear xi.
apply split_Euc in H0 as [l r].
exact (Rn H l, r).
Defined.
Notation "# n" := (split_Euc n) (at level 60, right associativity).
The main problem you cannot solve your goals is because of the definitional problem. Split_Euc is defined to perform induction on n, and that's okay however, the definitions perform an inversion on Euc. Inversion is normally a tactic for proofs, once the tactics generate very heavy proofs terms :
Fixpoint split_Euc {n m : nat} (xi : Euc (n + m)) : Euc n * Euc m.
Proof.
destruct n as [ | n].
- exact (RO, xi).
- inversion_clear xi.
Show Proof. (* let see what is actually the problem *)
...
Defined.
You'll see something like that :
eq_rec_r (fun n2 : nat => R -> Euc n2 -> Euc (S n0) * Euc m)
(fun (H6 : R) (H7 : Euc (n0 + m)) =>
?Goal#{n:=n0; H:=H6; H0:=H7}) H5) H3) H1 H H0
Notice your definition uses a proof (induction scheme of equality) term to make the join of the tuple. Proofs terms are not easily normalized and some others don't even get a normalized term (it is the case of Opaque proofs). The solution is to avoid tactics that generate heavy proofs terms and substitute for inductions schemes (like destruct, induction, case...), once they are "free" or almostt of automatic proofs.
Definition rect_euc {n : nat} (v : Euc (S n)) : forall (P : Euc (S n) -> Type) (H : forall ys a, P (a ::: ys)), P v.
refine (
match v with
|#Rn _ _ _ => _
|R0 => _
end).
exact idProp.
intros.
apply : H.
Defined.
Fixpoint split_Euc {n m : nat} (xi : Euc (n + m)) : Euc n * Euc m.
Proof.
destruct n as [ | n].
- exact (RO, xi).
- elim/#rect_euc : xi.
intros.
pose (split_Euc _ _ ys).
exact (Rn a (fst p), (snd p)).
Defined.
Now, as split_euc is defined using induction on n, you should do the same to get a straightforward proof.
Lemma AppendAndSplit {n m}(e:Euc n) (f:Euc m): # (e +++ f) = (e, f).
Proof.
induction n.
- remember 0.
destruct e.
reflexivity.
inversion Heqn.
- apply (rect_euc e).
intros.
assert (forall n (xs ys : Euc n) (x y : R), x = y -> xs = ys -> x ::: xs = y ::: ys).
intros.
rewrite H; rewrite H0; trivial.
pose (IHn ys).
apply : injective_projections.
simpl;apply : H; trivial.
exact (f_equal fst e0).
exact (f_equal snd e0).
Qed.
Lemma SplitRule {n m}(e:Euc (n+m)) : (fst (split_Euc e)) +++ (snd (split_Euc e)) = e.
YOUR_TURN. (* now it's your turn, just do the same and u will get the goal*)
Qed.

Transform the lemma leaving previous state on Coq

I want to partially derive functions whose input is a dependent list.
I tried to define deriveP with proving.
Derive is a function in Coquelicot.Derive.
Definition deriveP {P A B}(k:nat)(I:Euc (S P) -> Euc A -> Euc B)
(input:Euc A)(train:Euc B)(p :Euc (S P))
:(lt k (S P)) -> (lt ((S P)-(k+1)) (S P)) -> R.
intros.
pose fk := firstk k (S P) p H.
pose lk := lastk ((S P)-(k+1)) (S P) p H0.
pose pk := EucNth k p.
apply arith_basic in H.
exact ( Derive (fun PK => EucSum (QuadraticError (I (fk +++ (PK ::: lk)) input) train )) pk ).
I can not apply arith_basic poposed by Tiago because H is used in fk.
I can apply arith_basic to H before I make fk, but then I can not make fk because There is not k < P.+1.
I want to apply arith_basic to H while leaving k < P.+1.
Please help me.
(***********************************************************)
This is dependent list of R.
Require Import Coq.Reals.Reals.
Require Import Coquelicot.Coquelicot.
Inductive Euc:nat -> Type:=
|RO : Euc 0
|Rn : forall {n:nat}, R -> Euc n -> Euc (S n).
Notation "[ ]" := RO.
Notation "[ r1 , .. , r2 ]" := (Rn r1 .. ( Rn r2 RO ) .. ).
Infix ":::" := Rn (at level 60, right associativity).
Basic list operation.
Definition head {n} (v : Euc (S n)) : R :=
match v with
| x ::: _ => x
end.
Definition tail {n} (v : Euc (S n)) : Euc n :=
match v with
| _ ::: v => v
end.
(* extract the last element *)
Fixpoint last {n} : Euc (S n) -> R :=
match n with
| 0%nat => fun v => head v
| S n => fun v => last (tail v)
end.
(* eliminate last element from list *)
Fixpoint but_last {n} : Euc (S n) -> Euc n :=
match n with
| 0%nat => fun _ => []
| S n => fun v => head v ::: but_last (tail v)
end.
(* do the opposite of cons *)
Fixpoint snoc {n} (v : Euc n) (x : R) : Euc (S n) :=
match v with
| [] => [x]
| y ::: v => y ::: snoc v x
end.
(* extract last k elements *)
Fixpoint lastk k n : Euc n -> (lt k n) -> Euc k :=
match n with
|0%nat => fun _ (H : lt k 0) => False_rect _ (Lt.lt_n_O _ H)
|S n => match k with
|S m => fun v H => snoc (lastk m n (but_last v) (le_S_n _ _ H)) (last v)
|0%nat => fun _ H => []
end
end.
(* extract first k elements *)
Fixpoint firstk k n : Euc n -> (lt k n) -> Euc k :=
match n with
|0%nat => fun _ (H :lt k 0) => False_rect _ (Lt.lt_n_O _ H)
|S n => match k with
|S m => fun v H => (head v) ::: firstk m n (tail v) (le_S_n _ _ H)
|0%nat => fun _ _ => []
end
end.
(* extract nth element *)
(* 0 origine *)
Fixpoint EucNth (k:nat) :forall {n}, Euc (S n) -> R:=
match k with
| 0%nat => fun _ e => head e
| S k' => fun n =>
match n return Euc (S n) -> R with
| 0%nat => fun e => head e
| S n' => fun v => EucNth k' (tail v)
end
end.
Fixpoint EucAppend {n m} (e:Euc n) (f:Euc m) :Euc (n+m):=
match e with
|[] => f
|e' ::: es => e' ::: (EucAppend es f)
end.
Infix "+++" := EucAppend (at level 60, right associativity).
Fixpoint QuadraticError {n : nat} (b : Euc n) : Euc n -> Euc n.
refine (match b in Euc n return Euc n -> Euc n with
|#Rn m x xs => _
|#RO => fun H => []
end).
remember (S m).
intro H; destruct H as [| k y ys].
inversion Heqn0.
inversion Heqn0.
subst; exact ((x - y)^2 ::: QuadraticError _ xs ys).
Defined.
Fixpoint EucSum {A}(e:Euc A) :R:=
match e with
| [] => 0%R
| e' ::: es => e' + (EucSum es)
end.
Your lemma k + S (P - (k + 1)) = P can be solved just with basic algebraic operations.
Particularly you just need two lemmas to make this easier:
Theorem minus_assoc : forall y z, z < y -> z + (y - z) = y.
intro y.
induction y.
intros;inversion H.
intros.
destruct z.
trivial.
rewrite PeanoNat.Nat.sub_succ.
rewrite <- (IHy _ (le_S_n _ _ H)) at 2; trivial.
Qed.
Theorem minus_S : forall x y, y < x -> S (x - (S y)) = x - y.
intro.
induction x.
intros.
inversion H.
intros.
destruct y.
simpl.
rewrite PeanoNat.Nat.sub_0_r; trivial.
rewrite PeanoNat.Nat.sub_succ.
apply IHx.
exact (le_S_n _ _ H).
Qed.
Now you just have to rewrite your goal to a trivial preposition :
Theorem arith_basic : forall k P, k < P -> k + S (P - (k + 1)) = P.
intros.
rewrite PeanoNat.Nat.add_1_r.
rewrite minus_S.
auto.
rewrite minus_assoc.
assumption.
trivial.
Qed.
Most of these kinds of goals can solve by lia tactic which automatically solves arithmetics goals of Z, nat, positive, and N.
Theorem arith_basic : forall k P, k < P -> k + S (P - (k + 1)) = P.
intros;lia.
Qed
Even though I recommend automation, proving by hands can help understand your main goal which may be not able to be solved by only automation.
I have solved on my own.
We can duplicate lemma in the sub-goal with generalize tactic.
Definition deriveP {P A B}(k:nat)(I:Euc (S P) -> Euc A -> Euc B)
(input:Euc A)(train:Euc B)(p :Euc (S P))
:(lt k (S P)) -> (lt ((S P)-(k+1)) (S P)) -> R.
intros.
generalize H.
intro H1.
apply arith_basic in H1.
pose lk := lastk ((S P)-(k+1)) (S P) p H0.
pose fk := firstk k (S P) p H.
pose pk := EucNth k p.
rewrite (_: (P.+1)%nat = (k + (P.+1 - (k + 1)%coq_nat)%coq_nat.+1)%coq_nat) in I.
exact ( Derive (fun PK => EucSum (QuadraticError (I (fk +++ (PK ::: lk)) input) train )) pk ).
apply H1.
Defined.

Functional extensionality for John Major's equality

Is functional extensionality provable for John Major's equality (possibly relying on safe axioms)?
Goal forall A (P:A->Type) (Q:A->Type)
(f:forall a, P a) (g:forall a, Q a),
(forall a, JMeq (f a) (g a)) -> JMeq f g.
If not, is it safe to assume it as an axiom?
It's provable from usual function extensionality.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.JMeq.
Theorem jmeq_funext
A (P : A -> Type) (Q : A -> Type)
(f : forall a, P a)(g : forall a, Q a)
(h : forall a, JMeq (f a) (g a)) : JMeq f g.
Proof.
assert (pq_eq : P = Q).
apply functional_extensionality.
exact (fun a => match (h a) with JMeq_refl => eq_refl end).
induction pq_eq.
assert (fg_eq : f = g).
apply functional_extensionality_dep.
exact (fun a => JMeq_rect (fun ga => f a = ga) eq_refl (h a)).
induction fg_eq.
exact JMeq_refl.
Qed.

Ltac call to "cofix" failed. Error: All methods must construct elements in coinductive types

Require Import Streams.
CoFixpoint map {X Y : Type} (f : X -> Y) (s : Stream X) : Stream Y :=
Cons (f (hd s)) (map f (tl s)).
CoFixpoint interleave {X : Type} (s : Stream X * Stream X) : Stream X := Cons (hd (fst s)) (Cons (hd (snd s)) (interleave (tl (fst s), tl (snd s)))).
Lemma map_interleave : forall {X Y : Type} (f : X -> Y) (s1 s2 : Stream X), map f (interleave (s1, s2)) = interleave (map f s1, map f s2).
Proof.
Fail cofix. (* error *)
Abort.
Output:
Ltac call to "cofix" failed.
Error: All methods must construct elements in coinductive types.
I'm not sure what this means - both map and interleave are straightforward corecursive functions building values of coinductive types. What's the problem?
The problem stems from the fact that = notation stands for eq, which is an inductive type, not a coinductive one.
Instead, you can show that the streams map f (interleave (s1, s2)) and interleave (map f s1, map f s2) are extensionally equal. Here is an excerpt from the Coq reference manual (§1.3.3)
In order to prove the extensionally equality of two streams s1 and s2 we have to construct an infinite proof of equality, that is, an infinite object of type EqSt s1 s2.
After changing eq to EqSt we can prove the lemma:
Lemma map_interleave : forall {X Y : Type} (f : X -> Y) (s1 s2 : Stream X),
EqSt (map f (interleave (s1, s2))) (interleave (map f s1, map f s2)).
Proof.
cofix.
intros X Y f s1 s2.
do 2 (apply eqst; [reflexivity |]).
case s1 as [h1 s1], s2 as [h2 s2].
change (tl (tl (map f (interleave (Cons h1 s1, Cons h2 s2))))) with
(map f (interleave (s1, s2))).
change (tl (tl (interleave (map f (Cons h1 s1), map f (Cons h2 s2))))) with
(interleave (map f s1, map f s2)).
apply map_interleave.
Qed.
By the way, many tricks dealing with coinductive datatypes can be found in this CPDT chapter.

How to use a custom induction principle in Coq?

I read that the induction principle for a type is just a theorem about a proposition P. So I constructed an induction principle for List based on the right (or reverse) list constructor .
Definition rcons {X:Type} (l:list X) (x:X) : list X :=
l ++ x::nil.
The induction principle itself is:
Definition true_for_nil {X:Type}(P:list X -> Prop) : Prop :=
P nil.
Definition true_for_list {X:Type} (P:list X -> Prop) : Prop :=
forall xs, P xs.
Definition preserved_by_rcons {X:Type} (P: list X -> Prop): Prop :=
forall xs' x, P xs' -> P (rcons xs' x).
Theorem list_ind_rcons:
forall {X:Type} (P:list X -> Prop),
true_for_nil P ->
preserved_by_rcons P ->
true_for_list P.
Proof. Admitted.
But now, I am having trouble using the theorem. I don't how to invoke it to achieve the same as the induction tactic.
For example, I tried:
Theorem rev_app_dist: forall {X} (l1 l2:list X), rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof. intros X l1 l2.
induction l2 using list_ind_rcons.
But in the last line, I got:
Error: Cannot recognize an induction scheme.
What are the correct steps to define and apply a custom induction principle like list_ind_rcons?
Thanks
If one would like to preserve the intermediate definitions, then one could use the Section mechanism, like so:
Require Import Coq.Lists.List. Import ListNotations.
Definition rcons {X:Type} (l:list X) (x:X) : list X :=
l ++ [x].
Section custom_induction_principle.
Variable X : Type.
Variable P : list X -> Prop.
Hypothesis true_for_nil : P nil.
Hypothesis true_for_list : forall xs, P xs.
Hypothesis preserved_by_rcons : forall xs' x, P xs' -> P (rcons xs' x).
Fixpoint list_ind_rcons (xs : list X) : P xs. Admitted.
End custom_induction_principle.
Coq substitutes the definitions and list_ind_rcons has the needed type and induction ... using ... works:
Theorem rev_app_dist: forall {X} (l1 l2:list X),
rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof. intros X l1 l2.
induction l2 using list_ind_rcons.
Abort.
By the way, this induction principle is present in the standard library (List module):
Coq < Check rev_ind.
rev_ind
: forall (A : Type) (P : list A -> Prop),
P [] ->
(forall (x : A) (l : list A), P l -> P (l ++ [x])) ->
forall l : list A, P l
What you did was mostly correct. The problem is that Coq has some trouble recognizing that what you wrote is an induction principle, because of the intermediate definitions. This, for instance, works just fine:
Theorem list_ind_rcons:
forall {X:Type} (P:list X -> Prop),
P nil ->
(forall x l, P l -> P (rcons l x)) ->
forall l, P l.
Proof. Admitted.
Theorem rev_app_dist: forall {X} (l1 l2:list X), rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof. intros X l1 l2.
induction l2 using #list_ind_rcons.
I don't know if Coq not being able to automatically unfold the intermediate definitions should be considered a bug or not, but at least there is a workaround.