The fold tactic replaces all occurrence of a term with another, so fold (id f) tries to replace all occurrences of f with (id f).
However, I want to only fold f if it occurs in the context (f [ ]), not if it occurs in the context ([ ] f). In particular repeat myfold (id f), should not loop.
Is there a general way to do this type of folding? The best I have right now is
repeat match goal with
| |- context [(f ?x)] => change (f x) with ((id f) x)
end
But the above does not work for contexts of the form forall x, f x = f x.
You can use an intermediate value not containing f. Something like
let f' := fresh in
pose (id f) as f';
change f with f'
change (id f') with f'; (* undo the change in locations where we've already added id *)
subst f'.
Edit
If you actually want to just fold things in applicative contexts, you can use three intermediate values, like this:
(* Copyright 2018 Google LLC.
SPDX-License-Identifier: Apache-2.0 *)
Ltac myfold_id f :=
let id_f := fresh in
let id_f_good := fresh in
let f' := fresh in
pose (id f) as id_f;
pose (id f) as id_f_good;
pose f as f';
repeat (change f with id_f at 1;
lazymatch goal with
| [ |- context[id_f _] ] => change id_f with id_f_good
| _ => change id_f with f'
end);
subst id_f id_f_good f'.
Goal let f := id in (f = f, f 0) = (f = f, f 0).
Proof.
intro f.
(* (f = f, f 0) = (f = f, f 0) *)
myfold_id f.
(* (f = f, id f 0) = (f = f, id f 0) *)
Related
I'm trying to prove that injective functions are left invertible in Coq. I've reached a point in my proof where my goal is an "exists" proposition. I want to define a function that uses terms from proof scope (types and functions I've intro'ed before) and then show the function to the "exists" goal. Here's what I wrote so far:
(* function composition *)
Definition fun_comp {A B C: Type} (f:A -> B) (g:B -> C) : A -> C :=
fun a: A => g (f a).
Notation "g .o f" := (fun_comp f g) (at level 70).
Definition nonempty (A: Type) := exists a: A, a = a.
(* identity function for any given type *)
Definition fun_id (A: Type) := fun a: A => a.
(* left invertible *)
Definition l_invertible {A B: Type} (f: A -> B) :=
exists fl:B->A, fl .o f = fun_id A.
Definition injective {A B: Type} (f: A -> B) :=
forall a a': A, f a = f a' -> a = a'.
(* is a given element in a function's image? *)
Definition elem_in_fun_image {A B: Type} (b: B) (f: A -> B) :=
exists a: A, f a = b.
Theorem injective_is_l_invertible:
forall (A B: Type) (f: A -> B), nonempty A /\ injective f -> l_invertible f.
Proof.
intros A B f H.
destruct H as [Hnempty Hinj].
unfold l_invertible.
unfold nonempty in Hnempty.
destruct Hnempty as [a0].
(* here would go my function definition and invoking "exists myfun" *)
Here's the function I'm trying to define:
Definition fL (b: B) := if elem_in_fun_image b f
then f a
else a0.
Here's what the proof window looks like:
1 subgoal
A : Type
B : Type
f : A -> B
a0 : A
H : a0 = a0
Hinj : injective f
========================= (1 / 1)
exists fl : B -> A, (fl .o f) = fun_id A
How do I do this? I'm very new to Coq so other comments and pointers are welcome.
This definition cannot be performed in the basic logic. You need to add in a few extra axioms:
(* from Coq.Logic.FunctionalExtensionality *)
functional_extensionality : forall A B (f g : A -> B),
(forall x, f x = g x) -> f = g
(* from Coq.Logic.Classical *)
classic : forall P : Prop, P \/ ~ P
(* from Coq.Logic.ClassicalChoice *)
choice : forall (A B : Type) (R : A->B->Prop),
(forall x : A, exists y : B, R x y) ->
exists f : A->B, (forall x : A, R x (f x)).
The goal is to define a relation R that characterizes the left inverse that you want to construct. The existentially quantified f will then be the inverse! You will need the classic axiom to show the precondition of choice, and you will need functional extensionality to show the equation that you want. I'll leave it as an exercise to find out what R needs to be and how to complete the proof.
Your script should start with the following line.
Require Import ClassicalChoice FunctionalEquality.
Because, as suggested by #arthur-azevedo-de-amorim, you will need these axioms.
Then, you should use choice with the relation "R y x" being
"f x = A or there is no element in A such whose image by f is y".
You will need the axiom classic to prove the existential statement that is required by choice:
assert (pointwise : forall y: B, exists x : A,
f x = y \/ (forall x : A f x <> y)).
choice will give you an existential statement for a function that returns the value you want. You only need to say that this function is the right one. You can give a name to that function by typing destruct (choice ... pointwise) (you have to fill in the ...).
You will have to prove an equality between two functions, but using the axiom functional_extensionality, you can reduce this problem to just proving that the two functions are equal on any x.
For that x, just instantiate the characteristic property of the function (as produced by destruct (choice ... pointwise) with the
value f x. There is a disjuction, but the right-hand side case is self-contradictory, because obviously f x is f x for some x.
For the left-hand side case, you will get an hypothesis of the form (I name the function produced by (choice ... pointwise) with the name it:
f (it (f x)) = f x
Here you can apply your injectivity assumption. to deduce that it (f x) = x.
This pretty much spells out the proof. In my own, experiment, I used classic, NNP, not_all_ex_not, functional_extensionality, which are lemmas coming from ClassicalChoice of FunctionalEquality.
I am trying to formalize some intuitionistic notions. One of these is the continuity principle. In Coq I defined this as:
(* Infinite sequences *)
Definition N := nat -> nat.
(* The first n elements of a and b coincide. *)
Definition con (a b : N) n := forall i, i < n -> a i = b i.
(* Brouwers Continuity Principle *)
Axiom BCP :
forall (R : N -> nat -> Prop),
(forall a, exists n, R a n) ->
(forall a, exists m n, forall b, con a b m -> R b n).
I want to generalize this to so called spreads. A spread is a subset of the Baire space that can be thought of as a tree with only infinite branches. A decider o (called the spread law) takes a finite starting sequence and returns 0 if it should be in the spread. When a sequence s is in the spread at least one extension n :: s must also be in the spread. The empty sequence must be accepted such that the spread is inhabited. I defined this as follows:
(* Spread law *)
Definition Spr_Law (o : list nat -> nat) :=
o [] = 0 /\ forall s, o s = 0 <-> exists n, o (n :: s) = 0.
One way to prove that the continuity principle generalizes to arbitrary spreads is to define a function that 'retracts' N onto a spread defined by such a decider o. This is where I get stuck because I simply do not know enough about Coq to define this well. First of all, I inserted a picture of this definition from the course notes.
The trouble is that this definition includes a 'smallest m such that o accepts m :: s'. This is not a terminating procedure in general and I do not know how to use Function to prove that this search would terminate for our purposes (it will since a spread law must accept at least one extension).
I found that I can use the Coq.Logic.ConstructiveEpsilon library to get a witness when I have an exists statement. I could pass the condition that at least one extension exists to the function. Based on this I created the following code (this is only the first part of the definition, which maps finite sequences onto the spread):
Definition find_extension o s (w : exists n, o (n :: s) = 0) : nat :=
constructive_ground_epsilon_nat (fun n => o (n :: s) = 0) (decider_dec o s) w.
(* Compute retraction for finite start sequences. *)
Fixpoint rho o (w : forall s, o s = 0 -> exists n, o (n :: s) = 0)
(s : list nat) : list nat :=
match s with
| [] => []
| n :: s => let t := rho o w s in
if o (n :: t) =? 0
then n :: t
else (find_extension o t (w t {?????})) :: t
end.
Now I encounter the real problem. The {?????} part is where I need to insert a proof that o t = 0. This holds since rho only ever returns sequences that are accepted by the decider o. Perhaps I can let rho return a tuple containing the new sequence together with a proof that this sequence is accepted (such that I can feed it into w after recursion), but I do not know how. Note that this is especially tricky for the else branch since the proof that this value is accepted holds because the witness is valid.
Of course alternative ideas for defining spreads are also welcome. I do feel that this is achievable though (there are no logical inconsistencies as far as I can see).
I seem to have figured something out:
(* Only sequences that are accepted by o *)
Inductive spr (o : decider) :=
| spr_s s : o s = 0 -> spr o.
(* Return smallest n such that o accepts n :: s. *)
Definition find_extension o s (witness : exists n, o (n :: s) = 0) : spr o :=
let P := (fun n => o (n :: s) = 0) in
let D := (decider_dec o s) in
spr_s o
((constructive_ground_epsilon_nat P D witness) :: s)
(constructive_ground_epsilon_spec_nat P D witness).
(*
To generalize BCP to spreads we first define a function that retracts the Baire
space onto an arbitrary spread given its spread law. This happens in two steps.
*)
(* Compute retraction for finite start sequences. *)
Fixpoint rho o
(Hnil : o [] = 0)
(Hcons : forall s, o s = 0 -> exists n, o (n :: s) = 0)
(s : list nat) : spr o :=
match s with
| [] => spr_s o [] Hnil
| n :: s =>
match rho o Hnil Hcons s with
| spr_s _ t Ht =>
match eq_dec (o (n :: t)) 0 with
| left Heq => spr_s o (n :: t) Heq
| right _ => find_extension o t (Hcons t Ht)
end
end
end.
(* Retraction of N onto F_o *)
Definition retract o
(Hnil : o [] = 0)
(Hcons : forall s, o s = 0 -> exists n, o (n :: s) = 0)
: N -> N :=
fun a => fun n =>
match rho o Hnil Hcons (get (n + 1) a) with
| spr_s _ [] _ => 0 (* not reachable *)
| spr_s _ (rho_n :: _) _ => rho_n
end.
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.
Consider the definition of find in the standard library, which as the type find: forall A : Type, (A -> bool) -> list A -> option A.
Of course, find has to return an option A and not an A because we don't know wether there is a "valid" element in the list.
Now, say I find this definition of find painful, because we have to deal with the option, even when we are sure that such an element exists in the list.
Hence, I'd like to define myFind which additionnaly takes a proof that there is such an element in the list. It would be something like:
Variable A: Type.
Fixpoint myFind
(f: A -> bool)
(l: list A)
(H: exists a, In a l /\ f a = true): A :=
...
If I am not mistaken, such a signature informally says: "Give me a function, a list, and a proof that you have a "valid" element in the list".
My question is: how can I use the hypothesis provided and define my fixpoint ?
What I have in mind is something like:
match l with
| nil => (* Use H to prove this case is not possible *)
| hd :: tl =>
if f hd
then hd
else
(* Use H and the fact that f hd = false
to prove H': exists a, In a tl /\ f a = true *)
myFind f tl H'
end.
An bonus point would be to know whether I can embbed a property about the result directly within the type, for instance in our case, a proof that the return value r is indeed such that f r = true.
We can implement this myFind function by structural recursion over the input list. In the case of empty list the False_rect inductive principle is our friend because it lets us switch from the logical world to the world of computations. In general we cannot destruct proofs of propositions if the type of the term under construction lives in Type, but if we have an inconsistency the system lets us.
We can handle the case of the non-empty input list by using the convoy pattern (there is a number of great answers on Stackoverflow explaining this pattern) and an auxiliary lemma find_not_head.
It might be useful to add that I use the convoy pattern twice in the implementation below: the one on the top level is used to let Coq know the input list is empty in the first match-branch -- observe that the type of H is different in both branches.
From Coq Require Import List.
Import ListNotations.
Set Implicit Arguments.
(* so we can write `f a` instead of `f a = true` *)
Coercion is_true : bool >-> Sortclass.
Section Find.
Variables (A : Type) (f : A -> bool).
(* auxiliary lemma *)
Fact find_not_head h l : f h = false ->
(exists a, In a (h :: l) /\ f a) ->
exists a, In a l /\ f a.
Proof. intros E [a [[contra | H] fa_true]]; [congruence | now exists a]. Qed.
Fixpoint myFind (l : list A) (H : exists a : A, In a l /\ f a) : {r : A | f r} :=
match l with
| [] => fun H : exists a : A, In a [] /\ f a =>
False_rect {r : A | f r}
match H with
| ex_intro _ _ (conj contra _) =>
match contra with end
end
| h :: l => fun H : exists a : A, In a (h :: l) /\ f a =>
(if f h as b return (f h = b -> {r : A | f r})
then fun Efh => exist _ h Efh
else fun Efh => myFind l (find_not_head Efh H)) eq_refl
end H.
End Find.
Here is a simplistic test:
From Coq Require Import Arith.
Section FindTest.
Notation l := [1; 2; 0; 9].
Notation f := (fun n => n =? 0).
Fact H : exists a, In a l /\ f a.
Proof. exists 0; intuition. Qed.
Compute myFind f l H.
(*
= exist (fun r : nat => f r) 0 eq_refl
: {r : nat | f r}
*)
End FindTest.
You can also use Program to help you construct the proof arguments interactively. You fill in as much as you can in the program body and leave _ blanks that you get to fill in later with proof tactics.
Require Import List Program.
Section Find.
Variable A : Type.
Variable test : A -> bool.
Program Fixpoint FIND l (H:exists a, test a = true /\ In a l) : {r | test r = true} :=
match l with
| [] => match (_:False) with end
| a::l' => if dec (test a) then a else FIND l' _
end.
Next Obligation.
firstorder; congruence.
Defined.
End Find.
Program is a little better at not forgetting information when you do case analysis (it knows the convoy pattern) but it is not perfect, hence the use of dec in the if statement.
(Notice how Coq was able to handle the first obligation, to construct a term of type False, all by itself!)
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.