I'm trying to prove a theorem involving a function that uses a destructuring let expression, and am trying to use the match goal tactic to destruct the right hand side, but for some reason the pattern doesn't match like I'd expect it to:
match goal with
(* why doesn't this match? *)
| [ |- context[let _ := ?X in _] ] => destruct X
end.
Here's a code snippet that should be runnable, if you have Cpdt from Certified Programming with Dependent Types (I'm a huge convert to his style of automation).
I have found a proof, but I'm planning on proving many more theorems with a similar shape, and I'd like to have an automated tactic capable of proving many of them.
Set Implicit Arguments. Set Asymmetric Patterns.
Require Import List Cpdt.CpdtTactics.
Import ListNotations.
Section PairList.
Variable K V: Set.
Variable K_eq_dec: forall x y: K, {x = y} + {x <> y}.
Variable V_eq_dec: forall x y: V, {x = y} + {x <> y}.
Definition Pair: Type := (K * V).
Definition PairList := list Pair.
(* ... *)
Fixpoint set (l: PairList) (key: K) (value: V): PairList :=
match l with
| [] => [(key, value)]
| pr::l' => let (k, _) := pr in
if K_eq_dec key k then (key, value)::l' else pr::(set l' key value)
end.
Theorem set_NotEmpty: forall (before after: PairList) key value,
after = set before key value -> after <> [].
Proof.
intros before after. induction before.
- crush.
- intros. rewrite -> H. simpl.
(* the context at this step:
1 subgoal
K, V : Set
K_eq_dec : ...
V_eq_dec : ...
a : Pair
before : list Pair
after : PairList
IHbefore: ...
key : K
value : V
H : ...
============================
(let (k, _) := a in
if K_eq_dec key k
then (key, value) :: before
else
a :: set before key value) <> []
*)
(* a successful proof
destruct a.
destruct (K_eq_dec key k); crush.
*)
match goal with
(* why doesn't this match? *)
| [ |- context[let _ := ?X in _] ] => destruct X
| [ |- context[(() <> [])] ] => idtac X
end.
(* the above command prints this:
(let (k, _) := a in
if K_eq_dec key k
then (key, value) :: before
else
a :: set before key value)
*)
Qed.
End PairList.
Destructuring lets are actually matches, so you need to look for a match. When a tactic doesn't match, you can see all expressions in your goal desugared with Set Printing All.
match goal with
| [ |- context[let _ := ?X in _] ] => destruct X
(* ADD THIS LINE *)
| [ |- context[match ?X with _ => _ end]] => destruct X
| [ |- context[(() <> [])] ] => idtac X
end.
Related
I try to prove the following theorem in Coq:
Theorem simple :
forall (n b:nat) (input output: list nat) , short (n::b::input) true (n::output) = None
-> short (b::input) false output = None.
with short as follows :
Fixpoint short (input: list nat) (starting : bool) (output: list nat) : option (list nat) :=
match input with
| nil => match output with
| nil => Some nil
| y::r => None
end
| x::rest => match output with
| nil => ...
| y::r => if ( beq_nat x y ) then match (short rest false r) with
| None => if (starting) then match (short rest starting output) with
| Some pp => Some (0 :: pp)
| None => None
end
else None
| Some pp => Some (x :: pp)
end
else ...
end.
The proof would be simple if I could control the conversion steps to start with
short (n::b::input) true (n::output)
and end up with something like:
match (short (b::input) false output) with
| None => match (short rest starting output) with
| Some pp => Some (0 :: pp)
| None => None
end
| Some pp => Some (x :: pp)
end
I've tried this :
Proof.
intros.
cbv delta in H.
cbv fix in H.
cbv beta in H.
cbv match in H.
rewrite Nat.eqb_refl in H.
...
but it seems that rewrite if doing more than a rewrite and performs a conversion I can't fold again to the desired form...
Any idea how this conversion can be done ?
Thank you !!
The cbn tactic looks like it does a decent job here:
Theorem simple :
forall (n b:nat) (input output: list nat) , short (n::b::input) true (n::output) = None
-> short (b::input) false output = None.
Proof.
intros.
cbn in *.
rewrite Nat.eqb_refl in H.
match goal with | |- ?t = _ => set (x := t) in * end.
destruct x.
all: congruence.
Qed.
In general, I would advise against cbv unless you want to really get eg a boolean. But if you want to do "just a bit of unfolding" cbn or simpl are usually better behaved.
Coq allows to write complex pattern-matchings, but then it decomposes them so that its kernel can handle them.
For instance, let us consider the following code.
Require Import List. Import ListNotations.
Inductive bar := A | B | C.
Definition f (l : list bar) :=
match l with
| _ :: A :: _ => 1
| _ => 2
end.
We pattern-match both on the list and on the second element. Printing f shows that Coq stores a more complex version of it.
Print f.
(* f = fun l : list bar => match l with
| [] => 2
| [_] => 2
| _ :: A :: _ => 1
| _ :: B :: _ => 2
| _ :: C :: _ => 2
end
: list bar -> nat
*)
The problem is that, in the proofs manipulating f, I have to deal with 5 cases instead of only 2, and 4 of them are redundant.
What is the best way to deal with this? Is there a way to reason with the pattern-matching as if it were exactly as defined?
You are correct in that Coq actually simplifies pattern-matching making a lot of redundancies appear.
There are however some ways to reason on the case analysis you meant opposed to what Coq understands.
Using Function and function induction is a way.
More recently, Equations also allows you to define pattern-matching for which it derives induction principles automatically (that you can invoke using funelim).
In order to convince coq cases can be factorised you have to use the notion of view.
They are described in the context of Equations in the examples.
I'll detail how to adapt your example to it.
From Equations Require Import Equations.
Require Import List. Import ListNotations.
Inductive bar := A | B | C.
Equations discr (b : list bar) : Prop :=
discr (_ :: A :: _) := False ;
discr _ := True.
Inductive view : list bar -> Set :=
| view_foo : forall x y, view (x :: A :: y)
| view_other : forall l, discr l -> view l.
Equations viewc l : view l :=
viewc (x :: A :: y) := view_foo x y ;
viewc l := view_other l I.
Equations f (l : list bar) : nat :=
f l with viewc l := {
| view_foo _ _ => 1 ;
| view_other _ _ => 2
}.
Goal forall l, f l < 3.
Proof.
intro l.
funelim (f l).
- repeat constructor.
- repeat constructor.
Qed.
As you can see, funelim only generates two subgoals.
It can be a bit heavy so if you don't want to use Equations of Function, you might have to prove your own induction principles by hand:
Require Import List. Import ListNotations.
Inductive bar := A | B | C.
Definition f (l : list bar) :=
match l with
| _ :: A :: _ => 1
| _ => 2
end.
Definition discr (l : list bar) : Prop :=
match l with
| _ :: A :: _ => False
| _ => True
end.
Lemma f_ind :
forall (P : list bar -> nat -> Prop),
(forall x y, P (x :: A :: y) 1) ->
(forall l, discr l -> P l 2) ->
forall l, P l (f l).
Proof.
intros P h1 h2 l.
destruct l as [| x [|[] l]].
3: eapply h1.
all: eapply h2.
all: exact I.
Qed.
Goal forall l, f l < 3.
Proof.
intro l.
eapply f_ind.
- intros. repeat constructor.
- intros. repeat constructor.
Qed.
I have a pair of maps that are trivially incompatible. I'm wondering what's the graceful/automatized way to get a proof of it.
Require Import Coq.Strings.String.
(* Prelude: the total_map data structure from Software Foundations, slightly modified *)
Definition total_map := string -> nat.
Definition empty_st : total_map := (fun _ => 0).
Definition t_update (m : total_map) k v := fun k' => if string_dec k k' then v else m k'.
Notation "a '!->' x" := (t_update empty_st a x) (at level 100).
Notation "x '!->' v ';' m" := (t_update m x v) (at level 100, v at next level, right associativity).
(* The actual goal I'm trying to solve *)
Definition X: string := "X".
Definition Y: string := "Y".
Goal forall n, (X !-> n; Y !-> n) <> (X !-> 1; Y !-> 2).
Proof.
intros n contra.
remember (X !-> n; Y !-> n) as st.
remember (st X) as n1.
assert (n1 = n). { rewrite Heqn1; rewrite Heqst; cbv; reflexivity. }
assert (n1 = 1). { rewrite Heqn1; rewrite contra; cbv; reflexivity. }
remember (st Y) as n2.
assert (n2 = n). { rewrite Heqn2; rewrite Heqst; cbv; reflexivity. }
assert (n2 = 2). { rewrite Heqn2; rewrite contra; cbv; reflexivity. }
congruence.
Qed.
In order to automate this, you need to have a precise description of your proof strategy. Here is one possible proof strategy:
To prove an inequality of total_maps:
First introduce the equality hypothesis.
Then, for every key that's been added to either map, add the hypothesis that the value associated to that key is the same in both maps.
Then simplify all such equality hypotheses by unfolding t_update, using that string_dec x x is true, and seeing if any other string_decs compute down.
Finally, solve the goal by congruence.
We can automate each of these steps. Altogether, it becomes:
Require Import Coq.Strings.String.
(* Prelude: the total_map data structure from Software Foundations, slightly modified *)
Definition total_map := string -> nat.
Definition empty_st : total_map := (fun _ => 0).
Definition t_update (m : total_map) k v := fun k' => if string_dec k k' then v else m k'.
Notation "a '!->' x" := (t_update empty_st a x) (at level 100).
Notation "x '!->' v ';' m" := (t_update m x v) (at level 100, v at next level, right associativity).
(* Automation *)
(* 1. First introduce the equality hypothesis. *)
Ltac start_proving_inequality H :=
intro H.
(* 2. Then, for every key that's been added to either map, add the hypothesis that the value associated to that key is the same in both maps. *)
(* To do this, we need a tactic that will pose a proof only if it does not already exist. *)
Ltac unique_pose_proof lem :=
let T := type of lem in
lazymatch goal with
| [ H : T |- _ ] => fail 0 "A hypothesis of type" T "already exists"
| _ => pose proof lem
end.
(* Maybe move this elsewhere? *)
Definition t_get (m : total_map) k := m k.
Ltac saturate_with_keys H :=
repeat match type of H with
| context[t_update _ ?k ?v]
=> unique_pose_proof (f_equal (fun m => t_get m k) H)
end.
(* 3. Then simplify all such equality hypotheses by unfolding `t_update`, using that `string_dec x x` is true, and seeing if any other `string_dec`s compute down. *)
Require Import Coq.Logic.Eqdep_dec.
Lemma string_dec_refl x : string_dec x x = left eq_refl.
Proof.
destruct (string_dec x x); [ apply f_equal | congruence ].
apply UIP_dec, string_dec.
Qed.
(* N.B. You can add more cases here to deal with other sorts of ways you might reduce [t_get] here *)
Ltac simplify_t_get_t_update_in H :=
repeat first [ progress cbv [t_get t_update empty_st] in H
| match type of H with
| context[string_dec ?x ?x] => rewrite (string_dec_refl x) in H
| context[string_dec ?x ?y]
=> let v := (eval cbv in (string_dec x y)) in
(* check that it fully reduces *)
lazymatch v with left _ => idtac | right _ => idtac end;
progress change (string_dec x y) with v in H
end ].
Ltac simplify_t_get_t_update :=
(* first we must change hypotheses of the form [(fun m => t_get m k) m = (fun m => t_get m k) m'] into [t_get _ _ = t_get _ _] *)
cbv beta in *;
repeat match goal with
| [ H : t_get _ _ = t_get _ _ |- _ ] => progress simplify_t_get_t_update_in H
end.
(* 4. Finally, solve the goal by `congruence`. *)
Ltac finish_proving_inequality := congruence.
(* Now we put it all together *)
Ltac prove_total_map_inequality :=
let H := fresh in
start_proving_inequality H;
saturate_with_keys H;
simplify_t_get_t_update;
finish_proving_inequality.
(* The actual goal I'm trying to solve *)
Definition X: string := "X".
Definition Y: string := "Y".
Goal forall n, (X !-> n; Y !-> n) <> (X !-> 1; Y !-> 2).
intros.
prove_total_map_inequality.
Qed.
Based on Jason Gross's answer and the fact that total_map is a decidable type, I've put together a bit of automation to deal with this. Note that this problem would probably be a very good fit for small-scale reflection.
(* TODO: don't bring trivial (n = n) or duplicated hypotheses into scope *)
(* Given two maps left and right, plus a lemma that they are equal, plus some key: assert that the values of the maps agree at the specified key *)
Ltac invert_total_map_equality_for_id lemma left right id :=
let H := fresh "H" in
assert (left id = right id) as H by (rewrite lemma; reflexivity);
cbv in H.
(* Recurse on the LHS map, extracting keys *)
Ltac invert_total_map_equality_left lemma left right left_remaining :=
match left_remaining with
| t_update ?left_remaining' ?id _ =>
invert_total_map_equality_for_id lemma left right id;
invert_total_map_equality_left lemma left right left_remaining'
| _ => idtac
end.
(* Recurse on the RHS map, extracting keys; move on to LHS once we've done all RHS keys *)
Ltac invert_total_map_equality_right lemma left right right_remaining :=
match right_remaining with
| t_update ?right_remaining' ?id _ =>
invert_total_map_equality_for_id lemma left right id;
invert_total_map_equality_right lemma left right right_remaining'
| _ => invert_total_map_equality_left lemma left right left
end.
(* Given a lemma that two total maps are equal, assert that their values agree at each defined key *)
Ltac invert_total_map_equality lem :=
let T := type of lem in
match T with
| ?left = ?right =>
match type of left with
| string -> nat =>
match type of right with
| string -> nat =>
invert_total_map_equality_right lem left right right
end
end
end.
Goal forall n, (X !-> n; Y !-> n) <> (X !-> 1; Y !-> 2).
Proof.
unfold not; intros.
invert_total_map_equality H.
congruence.
Qed.
I'm proving a simple mathematical property about subsets, for example : A subset B; which is about the fact that adding a member to set B cannot affect this relation. In the program, A and B are list of pairs. entity_IN_listPair checks if a specific pair is in a list of pair and listPairEqual checks equality of two list of pairs. I am a bit stuck how to proceed in the proof of lemma Lemma addtolistPairSUB:
Require Import List.
Require Import Bool.
Definition entity := nat.
Definition entityID := nat.
Definition listPair : Set :=
list (entity * entityID).
(* Nat equality *)
Fixpoint Entity_eq (X:_) (a b:_) : bool :=
match a with
| O => match b with
| O => true
| S m' => false
end
| S n' => match b with
| O => false
| S m' => ( Entity_eq nat (n')( m'))
end
end.
(* checking if an entity is in an listPair *)
Fixpoint entity_IN_listPair
(entit: entity ) (lispair: listPair) : bool :=
match lispair with
|first::body => match first with
|(p_one,ptwo)=> (Entity_eq (nat)(entit)(p_one ))
|| entity_IN_listPair entit body
end
|nil => false
end.
(* checking the equality of two listPair *)
Fixpoint listPairSUB
(first second: listPair) : bool :=
match first with
|head::tail => match head with
|(part1,part2)=> if (entity_IN_listPair part1 second)
then listPairSUB tail second
else false
end
|nil => true
end.
Definition listPairEqual (firstL secondL:listPair) :=
(listPairSUB firstL secondL) && (listPairSUB secondL firstL).
Lemma addtolistPairSUB:
forall (a b: listPair ) (c:entity * entityID),
listPairSUB a b = true->listPairSUB (a) (c::b) = true .
Proof.
induction a.
Here it is. (I took the liberty of refactoring your code a little bit.)
Require Import List.
Require Import Bool.
Definition entity := nat.
Definition entityID := nat.
Definition listPair : Set :=
list (entity * entityID).
Fixpoint in_listpair e (l : listPair) :=
match l with
| nil => false
| (x, y) :: l' => Nat.eqb e x || in_listpair e l'
end.
Fixpoint subset_listpair (l1 l2 : listPair) :=
match l1 with
| nil => true
| (x1, _) :: l1 => in_listpair x1 l2 && subset_listpair l1 l2
end.
Lemma subset_listpair_cons l1 l2 p :
subset_listpair l1 l2 = true ->
subset_listpair l1 (p :: l2) = true.
Proof.
induction l1 as [|[x1 y1] l1 IH]; simpl; trivial.
destruct p as [x2 y2]; simpl.
destruct (in_listpair x1 l2); simpl; try easy.
intros H; rewrite IH; trivial.
now rewrite orb_true_r.
Qed.
I want to declare a function that yeilds the element (b, n) that the b is equal to true.
Require Export List.
Import Coq.Lists.List.ListNotations.
Definition lstest := list (bool * nat).
Fixpoint existbool (l : lstest) : option (bool * nat) :=
match l with
| [] => None
| (b, n) :: l' => if b then Some (b, n) else existbool l'
end.
The function always get the first element satisfyting b = true. I want to express that there exists an element satisfyting b = true and returns the element. How can I define such a function?
In the following function the type of existbool_ex tells you that we output a pair contained in the list with its first element true (assuming we output a Some).
(* These are all from the standard library *)
Locate "{ _ : _ | _ }".
Print sig.
Print In.
Print fst.
(* Defining Property here to shorten code for exist *)
Definition P l (x : bool * nat) := fst x = true /\ In x l.
Fixpoint existbool_ex (l : list (bool * nat)) :
option {x : bool * nat | fst x = true /\ In x l} :=
match l return option {x : bool * nat | P l x} with
| [] => None
| x' :: l' =>
match x' with
| (true,n) as ans =>
Some (exist (P (ans :: l')) ans (conj eq_refl (or_introl eq_refl)))
| (false,n) =>
match existbool_ex l' with
| None => None
| Some (exist _ x a) =>
match a with
| conj Heq Hin =>
Some (exist (P ((false, n) :: l')) x (conj Heq (or_intror Hin)))
end
end
end
end.
(* Note the as pattern got desugared into a let binding. *)
Print existbool_ex.
(* However we have a somewhat sane extraction, (tail recursive) *)
Require Extraction.
Extraction existbool_ex.
You could write a function get_number that requires a proof that the list has a true value somewhere.
Definition has_true (l : lstest):= exists n, In (true, n) l.
get_number is defined with the help of refine which lets us leave 'holes' (written _) in the proof term to fill in later. Here we have two holes; one for the absurd case when the list is [], and one where we construct the proof term for the recursive call.
Fixpoint get_number (l:lstest) (H: has_true l) : nat.
refine (
match l as l' return l' = _ -> nat with
| (true, n)::_ => fun L => n
| (false, _)::l' => fun L => get_number l' _
| [] => fun L => _
end eq_refl).
now exfalso; subst l; inversion H.
now subst l; inversion H; inversion H0;
[congruence | eexists; eauto].
Defined.
The function uses the convoy pattern so that the match statement does not forget the shape of l in the different branches.
If you want to, you can prove rewriting lemmas to make it easier to use.
Lemma get_number_false l m H: exists H', get_number ((false, m)::l) H = get_number l H'.
Proof. eexists; reflexivity. Qed.
Lemma get_number_true l m H: get_number ((true, m)::l) H = m.
Proof. reflexivity. Qed.
Lemma get_number_nil H m: get_number [] H <> m.
Proof. now inversion H. Qed.
Lemma get_number_proof_irrel l H1 H2: get_number l H1 = get_number l H2.
Proof. induction l as [ | [[|] ?] l']; eauto; now inversion H1. Qed.