I defined a Boole inductive type based on the disjoint sum's definition:
Inductive Boole :=
| inlb (a: unit)
| inrb (b: unit).
Given two types A and B I'm trying to prove the ismorphism between
sigT (fun x: Boole => prod ((eq x (inrb tt)) -> A) (eq x (inlb tt) -> B))
and
A + B
I managed to prove one side of the isomorphism
Definition sum_to_sigT {A} {B} (z: A + B) :
sigT (fun x: Boole => prod ((eq x (inrb tt)) -> A) (eq x (inlb tt) -> B)).
Proof.
case z.
move=> a.
exists (inrb tt).
rewrite //=.
move=> b.
exists (inlb tt).
rewrite //=.
Defined.
Lemma eq_inla_inltt (a: unit) : eq (inlb a) (inlb tt).
Proof.
by case a.
Qed.
Lemma eq_inra_inrtt (a: unit) : eq (inrb a) (inrb tt).
Proof.
by case a.
Qed.
Definition sigT_to_sum {A} {B}
(w: sigT (fun x: Boole => prod ((eq x (inrb tt)) -> A) (eq x (inlb tt) -> B))) :
A + B.
Proof.
destruct w.
destruct p.
destruct x.
apply (inr (b (eq_inla_inltt a0))).
apply (inl (a (eq_inra_inrtt b0))).
Defined.
Definition eq_sum_sigT {A} {B} (x: A + B):
eq x (sigT_to_sum (sum_to_sigT x)).
Proof.
by case x.
Defined.
But I'm in trouble in proving the other side, basically because I don't manage to establish equality between the different x and p involved in the following proof:
Definition eq_sigT_sum {A} {B}
(y: sigT (fun x: Boole => prod ((eq x (inrb tt)) -> A) (eq x (inlb tt) -> B))) : eq y (sum_to_sigT (sigT_to_sum y)).
Proof.
case: (sum_to_sigT (sigT_to_sum y)).
move=> x p.
destruct y.
destruct x.
destruct p.
Defined.
Does anyone know how I can prove the latter lemma?
Thanks for the help.
As bizarre as this sounds, you cannot prove this result in Coq's theory.
Let's call the type sigT (fun x => prod (eq x (inrb tt) -> A) (eq x (inlb tt) -> B)) simply T. Any element of T has the form existT x (pair f g), where x : Boole, f : eq x (inrb tt) -> A, and g : eq x (inlb tt) -> B. To show your result, you need to argue that two expressions of type T are equal, which will require at some point proving that two terms f1 and f2 of type eq x (inrb tt) -> A are equal.
The problem is that elements of eq x (inrb tt) -> A are functions: they take as input a proof that x and inrb tt are equal, and produce a term of type A as a result. And sadly, the notion of equality for functions in Coq is too weak to be useful in most cases. Normally in math, we would argue that two functions are equal by showing that they produce the same results, that is:
forall f g : A -> B,
(forall x : A, f x = g x) -> f = g.
This principle, usually known as functional extensionality, is not available in Coq by default. Fortunately, the theory allows us to safely add it as an axiom without compromising the soundness of the theory. It is even available to us in the standard library. I've included here a proof of a slightly modified version of your result. (I've taken the liberty of using the ssreflect library, since I saw you were using it too.)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype.
Require Import Coq.Logic.FunctionalExtensionality.
Section Iso.
Variables A B : Type.
Inductive sum' :=
| Sum' x of x = true -> A & x = false -> B.
Definition sum'_of_sum (x : A + B) :=
match x with
| inl a =>
Sum' true
(fun _ => a)
(fun e : true = false =>
match e in _ = c return if c then A else B with
| erefl => a
end)
| inr b =>
Sum' false
(fun e =>
match e in _ = c return if c then A else B with
| erefl => b
end)
(fun _ => b)
end.
Definition sum_of_sum' (x : sum') : A + B :=
let: Sum' b f g := x in
match b return (b = true -> A) -> (b = false -> B) -> A + B with
| true => fun f _ => inl (f erefl)
| false => fun _ g => inr (g erefl)
end f g.
Lemma sum_of_sum'K : cancel sum_of_sum' sum'_of_sum.
Proof.
case=> [[]] /= f g; congr Sum'; apply: functional_extensionality => x //;
by rewrite (eq_axiomK x).
Qed.
End Iso.
Related
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.
I am trying to prove that given
(eqX : relation X) (Hypo : Equivalence eqX) (f : X -> {x : X | P x})
then
eqX a b -> eqX (proj1_sig (f a)) (proj1_sig (f b))
The function f get a parameter of Type X and give an existing assertion {x : X | P x}. ( for example fun (n : nat) => {m : nat | S m = n} )
In one word, I would like to show that given two parameters which are equivalent under the equivalent relation eqX, then the destruct result of existing assertion {x : X | P x} is also of the same equivalence class.
Can I prove this goal directly(which means the Specif.sig hold this property), or I should prove or claim that f satisfy some constraint and after which can I get this assertion proven.
Your claim is not directly provable; consider
X := nat
eqX a b := (a mod 2) = (b mod 2)
P a := True
f x := exist P (x / 2) I
Then we have eqX 2 4 but we don't have eqX (proj1_sig (f 2)) (proj1_sig (f 4)) because we don't have eqX 1 2.
You can either take in the theorem you are trying to prove as a hypothesis, or you can take in a hypothesis of type forall a, proj1_sig (f a) = a, or you can take in a hypothesis of type forall a, eqX (proj1_sig (f a)) a. Note that all of these are provable (by reflexivity or intros; assumption) if you have f a := exist P a (g a) for some function g.
Is this what you are trying to show?
Require Import Coq.Relations.Relation_Definitions.
Require Import Coq.Classes.Equivalence.
Require Import Setoid.
Generalizable All Variables.
Lemma foo `{!#Equivalence A RA, #Equivalence B RB, f : #respecting A _ _ B _ _ , #equiv A _ _ a b} :
equiv (proj1_sig f a) (proj1_sig f b).
Proof.
now apply respecting_equiv.
Qed.
I try to practice subtypes in Coq, and using ssreflect to simplify things. But I always run into some problem when rewriting subtypes. For example:
Require Import Omega.
From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype.
(* a type A to build X *)
Inductive A: Set :=
| mkA: nat -> A.
Definition getNat_A (a: A) :=
match a with
| mkA n => n
end.
Inductive X: Set :=
| r1 : A -> X.
(* subtype of X that satisfying some property *)
Definition Instantiated_X (x : X) : bool :=
match x with
| r1 a => (getNat_A a) > 10
end.
Definition iX : Set := {x:X | (Instantiated_X x)}.
(* rewrite constructor of X, stating the fact of elements of A, under certain condition creates element of iX *)
Program Definition r1_rewrite : A -> option iX :=
fun a: A =>
match (Instantiated_X (r1 a)) with
| true => Some (exist _ (r1 a) _)
| false => None
end.
(* try to prove r1_rewrite is surjective *)
Example r1_rewrite_surj:
forall t : iX, exists (a : A),
match (r1_rewrite a) with
| None => True
| Some e => eq t e
end.
Proof.
intros.
destruct t eqn: caseiX.
destruct x eqn: caseX.
exists a.
destruct (r1_rewrite a) eqn: r_res.
- destruct (10 < getNat_A a) eqn: guard.
destruct i0.
destruct x0.
unfold r1_rewrite in r_res.
simpl in r_res.
rewrite <- guard in r_res. (* <- stuck *)
Abort.
I couldn't understand why it is stuck there. The error message saying:
Error: Abstracting over the term "true" leads to a term: ...
which is ill-typed.
I thought Coq would replace every occurrence of (10 < getNat_A a) with true in r_res, which leads to something like:
Some (exist (fun x : X => Instantiated_X x) (r1 a)
(r1_rewrite_obligation_1 a Heq_anonymous) =
Some (exist (fun x : X => Instantiated_X x) (r1 a0) i0)
and by proof irrelevance and r1 injectivity, allows my proof to go through. So, I wonder can I get some pointer about how I can massage r_res in this case so it facilitates rewriting.
edit: remove Eq type class, and its instances to make example more concise
The problem with your proof attempt is that you have to be careful about how you rewrite. Here is a possible solution.
Example r1_rewrite_surj:
forall t : iX, exists (a : A),
match (r1_rewrite a) with
| None => True
| Some e => eq t e
end.
Proof.
move=> [[a] Pa]; exists a; rewrite /r1_rewrite.
move: (erefl _); rewrite {1 3}Pa.
by move=> e; rewrite (eq_irrelevance (r1_rewrite_obligation_1 _ _) Pa).
Qed.
It is a bit tricky to see what is going on here. After the first line, the proof state looks like this:
a : A
Pa : Instantiated_X (r1 a)
============================
match
(if Instantiated_X (r1 a) as b return b = Instantiated_X (r1 a) -> option iX
then
fun H : true = Instantiated_X (r1 a) =>
Some (exist (fun x : X => Instantiated_X x) (r1 a) (r1_rewrite_obligation_1 a H))
else fun _ : false = Instantiated_X (r1 a) => None) (erefl (Instantiated_X (r1 a)))
with
| Some e => exist (fun x : X => Instantiated_X x) (r1 a) Pa = e
| None => True
end
If we try to rewrite with Pa at any of the occurrences below, we will get a type error. For example:
If we try to replace the first occurrence of Instantiated_X (r1 a), Coq will not allow us to apply the result of the if to (erefl (Instantiated_X (r1 a)).
We could solve the above issue by replacing the first, second, and sixth (the one on erefl) occurrences of Instantiated_X (r1 a) with true. This would also not work, as it would make the application of r1_rewrite_obligation_1 ill-typed.
The solution is to generalize over erefl (with the call move: (erefl _)), leading to the following proof state:
forall e : Instantiated_X (r1 a) = Instantiated_X (r1 a),
match
(if Instantiated_X (r1 a) as b return b = Instantiated_X (r1 a) -> option iX
then
fun H : true = Instantiated_X (r1 a) =>
Some (exist (fun x : X => Instantiated_X x) (r1 a) (r1_rewrite_obligation_1 a H))
else fun _ : false = Instantiated_X (r1 a) => None) e
with
| Some e0 => exist (fun x : X => Instantiated_X x) (r1 a) Pa = e0
| None => True
end
It is probably not easy to see, but at this point it is safe to rewrite with Pa to replace the first and third occurrences of Instantiated_X (r1 a), and allow the if to reduce. We can then conclude by appealing to proof irrelevance of boolean equality.
Needless to say, reasoning about typing problems in this way is a nightmare. As ejgallego pointed out, it is much easier in this case to reuse the subtyping machinery of ssreflect. For example:
(* Other definitions remain the same *)
Definition r1_rewrite a : option iX := insub (r1 a).
Example r1_rewrite_surj:
forall t : iX, exists (a : A),
match (r1_rewrite a) with
| None => True
| Some e => eq t e
end.
Proof.
by move=> [[a] Pa]; exists a; rewrite /r1_rewrite insubT.
Qed.
The insub function is a generic version of your r1_rewrite. It checks whether the property defining a subtype holds and, if so, pairs that object with the corresponding proof. The insubT lemma says that insub returns a Some when the property holds.
We have a function that inserts an element into a specific index of a list.
Fixpoint inject_into {A} (x : A) (l : list A) (n : nat) : option (list A) :=
match n, l with
| 0, _ => Some (x :: l)
| S k, [] => None
| S k, h :: t => let kwa := inject_into x t k
in match kwa with
| None => None
| Some l' => Some (h :: l')
end
end.
The following property of the aforementioned function is of relevance to the problem (proof omitted, straightforward induction on l with n not being fixed):
Theorem inject_correct_index : forall A x (l : list A) n,
n <= length l -> exists l', inject_into x l n = Some l'.
And we have a computational definition of permutations, with iota k being a list of nats [0...k]:
Fixpoint permute {A} (l : list A) : list (list A) :=
match l with
| [] => [[]]
| h :: t => flat_map (
fun x => map (
fun y => match inject_into h x y with
| None => []
| Some permutations => permutations
end
) (iota (length t))) (permute t)
end.
The theorem we're trying to prove:
Theorem num_permutations : forall A (l : list A) k,
length l = k -> length (permute l) = factorial k.
By induction on l we can (eventually) get to following goal: length (permute (a :: l)) = S (length l) * length (permute l). If we now simply cbn, the resulting goal is stated as follows:
length
(flat_map
(fun x : list A =>
map
(fun y : nat =>
match inject_into a x y with
| Some permutations => permutations
| None => []
end) (iota (length l))) (permute l)) =
length (permute l) + length l * length (permute l)
Here I would like to proceed by destruct (inject_into a x y), which is impossible considering x and y are lambda arguments. Please note that we will never get the None branch as a result of the lemma inject_correct_index.
How does one proceed from this proof state? (Please do note that I am not trying to simply complete the proof of the theorem, that's completely irrelevant.)
There is a way to rewrite under binders: the setoid_rewrite tactic (see ยง27.3.1 of the Coq Reference manual).
However, direct rewriting under lambdas is not possible without assuming an axiom as powerful as the axiom of functional extensionality (functional_extensionality).
Otherwise, we could have proved:
(* classical example *)
Goal (fun n => n + 0) = (fun n => n).
Fail setoid_rewrite <- plus_n_O.
Abort.
See here for more detail.
Nevertheless, if you are willing to accept such axiom, then you can use the approach described by Matthieu Sozeau in this Coq Club post to rewrite under lambdas like so:
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.Morphisms.
Generalizable All Variables.
Instance pointwise_eq_ext {A B : Type} `(sb : subrelation B RB eq)
: subrelation (pointwise_relation A RB) eq.
Proof. intros f g Hfg. apply functional_extensionality. intro x; apply sb, (Hfg x). Qed.
Goal (fun n => n + 0) = (fun n => n).
setoid_rewrite <- plus_n_O.
reflexivity.
Qed.
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.