I was trying to code into Coq logical connectives encoded in lambda calculus with type à la System F. Here is the bunch of code I wrote (standard things, I think)
Definition True := forall X: Prop, X -> X.
Lemma I: True.
Proof.
unfold True. intros. apply H.
Qed.
Section s.
Variables A B: Prop.
(* conjunction *)
Definition and := forall X: Prop, (A -> B -> X) -> X.
Infix "/\" := and.
Lemma and_intro: A -> B -> A/\B.
Proof.
intros HA HB. split.
apply HA.
apply HB.
Qed.
Lemma and_elim_l: A/\B -> A.
Proof.
intros H. destruct H as [HA HB]. apply HA.
Qed.
Lemma and_elim_r: A/\B -> B.
Proof.
intros H. destruct H as [HA HB]. apply HB.
Qed.
(* disjunction *)
Definition or := forall X:Prop, (A -> X) -> (B -> X) -> X.
Infix "\/" := or.
Lemma or_intro_l: A -> A\/B.
intros HA. left. apply HA.
Qed.
Lemma or_elim: forall C:Prop, A \/ B -> (A -> C) -> (B -> C) -> C.
Proof.
intros C HOR HAC HBC. destruct HOR.
apply (HAC H).
apply (HBC H).
Qed.
(* falsity *)
Definition False := forall Y:Prop, Y.
Lemma false_elim: False -> A.
Proof.
unfold False. intros. apply (H A).
Qed.
End s.
Basically, I wrote down the elimination and introduction laws for conjunction, disjunction, true and false. I am not sure of having done thing correctly, but I think that things should work that way. Now I would like to define the existential quantification, but I have no idea of how to proceed. Does anyone have a suggestion?
Existential quantification is just a generalization of conjunction, where the type of the second component of the pair depends on the value of the first component. When there's no dependency they're equivalent:
Goal forall P1 P2 : Prop, (exists _ : P1, P2) <-> P1 /\ P2.
Proof. split. intros [H1 H2]. eauto. intros [H1 H2]. eauto. Qed.
Coq'Art has a section on impredicativity starting at page 130.
Definition ex (T1 : Type) (P1 : T1 -> Prop) : Prop :=
forall P2 : Prop, (forall x1, P1 x1 -> P2) -> P2.
Notation "'exists' x1 .. x2 , P1" :=
(ex (fun x1 => .. (ex (fun x2 => P1)) ..))
(at level 200, x1 binder, right associativity,
format "'[' 'exists' '/ ' x1 .. x2 , '/ ' P1 ']'") : type_scope.
The problem with impredicative definitions (unless I'm mistaken) is that there's no dependent elimination. It's possible prove
forall (A : Type) (P : A -> Prop) (Q : Prop),
(forall x : A, P x -> Q) -> (exists x, P x) -> Q,
but not
forall (A : Type) (P : A -> Prop) (Q : (exists x, P x) -> Prop),
(forall (x : A) (H : P x), Q (ex_intro P x H)) ->
forall H : exists x, P x, Q H
Related
I want to build a proof of correctness for elements_tr...
It is actually related to some sort of reimplementation of BSTs with int keys.
Elements_tr is defined as follows:
Fixpoint elements_aux {V : Type} (t : tree V)
(acc : list (key * V)) : list (key * V) :=
match t with
| E => acc
| T l k v r => elements_aux l ((k, v) :: elements_aux r acc)
end.
Definition elements_tr {V : Type} (t : tree V) : list (key * V) :=
elements_aux t [].
However I am unable to build such proof as I continuously get false = true...
What Am I doing wrong?
Corollary elements_tr_correct :
forall (V : Type) (k : key) (v d : V) (t : tree V),
BST t ->
In (k, v) (elements_tr t) ->
bound k t = true /\ lookup d k t = v.
Proof.
intros.
split.
induction t.
- unfold elements_tr.
unfold elements. simpl.
admit.
- admit.
- admit.
Admitted.
Bellow is the full code to run...
From Coq Require Import String.
From Coq Require Export Arith.
From Coq Require Export Lia.
Notation "a >=? b" := (Nat.leb b a) (at level 70) : nat_scope.
Notation "a >? b" := (Nat.ltb b a) (at level 70) : nat_scope.
From Coq Require Export Lists.List.
Export ListNotations.
Definition key := nat.
Inductive tree (V : Type) : Type :=
| E
| T (l : tree V) (k : key) (v : V) (r : tree V).
Arguments E {V}.
Arguments T {V}.
Definition ex_tree : tree string :=
(T (T E 2 "two" E) 4 "four" (T E 5 "five" E))%string.
Definition empty_tree {V : Type} : tree V := E.
Fixpoint bound {V : Type} (x : key) (t : tree V) :=
match t with
| E => false
| T l y v r => if x <? y then bound x l
else if x >? y then bound x r
else true
end.
Fixpoint lookup {V : Type} (d : V) (x : key) (t : tree V) : V :=
match t with
| E => d
| T l y v r => if x <? y then lookup d x l
else if x >? y then lookup d x r
else v
end.
Fixpoint insert {V : Type} (x : key) (v : V) (t : tree V) : tree V :=
match t with
| E => T E x v E
| T l y v' r => if x <? y then T (insert x v l) y v' r
else if x >? y then T l y v' (insert x v r)
else T l x v r
end.
Fixpoint ForallT {V : Type} (P: key -> V -> Prop) (t: tree V) : Prop :=
match t with
| E => True
| T l k v r => P k v /\ ForallT P l /\ ForallT P r
end.
Inductive BST {V : Type} : tree V -> Prop :=
| BST_E : BST E
| BST_T : forall l x v r,
ForallT (fun y _ => y < x) l ->
ForallT (fun y _ => y > x) r ->
BST l ->
BST r ->
BST (T l x v r).
Hint Constructors BST.
Ltac inv H := inversion H; clear H; subst.
Inductive reflect (P : Prop) : bool -> Set :=
| ReflectT : P -> reflect P true
| ReflectF : ~ P -> reflect P false.
Theorem iff_reflect : forall P b, (P <-> b = true) -> reflect P b.
Proof.
intros P b H. destruct b.
- apply ReflectT. rewrite H. reflexivity.
- apply ReflectF. rewrite H. intros H'. inversion H'.
Qed.
Lemma eqb_reflect : forall x y, reflect (x = y) (x =? y).
Proof.
intros x y. apply iff_reflect. symmetry.
apply Nat.eqb_eq.
Qed.
Lemma ltb_reflect : forall x y, reflect (x < y) (x <? y).
Proof.
intros x y. apply iff_reflect. symmetry.
apply Nat.ltb_lt.
Qed.
Lemma leb_reflect : forall x y, reflect (x <= y) (x <=? y).
Proof.
intros x y. apply iff_reflect. symmetry.
apply Nat.leb_le.
Qed.
Hint Resolve ltb_reflect leb_reflect eqb_reflect : bdestruct.
Ltac bdestruct X :=
let H := fresh in let e := fresh "e" in
evar (e: Prop);
assert (H: reflect e X); subst e;
[eauto with bdestruct
| destruct H as [H|H];
[ | try first [apply not_lt in H | apply not_le in H]]].
Lemma ForallT_insert : forall (V : Type) (P : key -> V -> Prop) (t : tree V),
ForallT P t -> forall (k : key) (v : V),
P k v -> ForallT P (insert k v t).
Proof.
intros V P t.
induction t; intros H k' v' Pkv.
- simpl. auto.
- simpl in *.
destruct H as [H1 [H2 H3]].
bdestruct (k >? k').
+ simpl. repeat split.
* assumption.
* apply (IHt1 H2 k' v' Pkv).
* assumption.
+ bdestruct (k' >? k).
++ simpl. repeat split.
* assumption.
* assumption.
* apply (IHt2 H3 k' v' Pkv).
++ simpl. repeat split.
* assumption.
* assumption.
* assumption.
Qed.
Fixpoint elements {V : Type} (t : tree V) : list (key * V) :=
match t with
| E => []
| T l k v r => elements l ++ [(k, v)] ++ elements r
end.
Fixpoint elements_aux {V : Type} (t : tree V)
(acc : list (key * V)) : list (key * V) :=
match t with
| E => acc
| T l k v r => elements_aux l ((k, v) :: elements_aux r acc)
end.
Definition elements_tr {V : Type} (t : tree V) : list (key * V) :=
elements_aux t [].
Corollary elements_tr_correct :
forall (V : Type) (k : key) (v d : V) (t : tree V),
BST t ->
In (k, v) (elements_tr t) ->
bound k t = true /\ lookup d k t = v.
Proof.
intros.
split.
induction t.
- unfold elements_tr.
unfold elements. simpl.
admit.
- admit.
- admit.
Admitted.
I have the following inductive definition for sortedness of a list:
Class DecTotalOrder (A : Type) := {
leb : A -> A -> bool;
leb_total_dec : forall x y, {leb x y}+{leb y x};
leb_antisym : forall x y, leb x y -> leb y x -> x = y;
leb_trans : forall x y z, leb x y -> leb y z -> leb x z }.
Inductive Sorted {A} {dto : DecTotalOrder A} : list A -> Prop :=
| Sorted_0 : Sorted []
| Sorted_1 : forall x, Sorted [x]
| Sorted_2 : forall x y, leb x y ->
forall l, Sorted (y :: l) ->
Sorted (x :: y :: l).
And the following two definitions to declare that an element x is smaller or equal than each element of the list (LeLst) and bigger or equal than each element of the list (LstLe) :
Definition LeLst {A} {dto : DecTotalOrder A} (x : A) (l : list A) :=
List.Forall (leb x) l.
Definition LstLe {A} {dto : DecTotalOrder A} (x : A) (l : list A) :=
List.Forall (fun y => leb y x) l.
I am trying to prove the following lemma about sortedness which basically states that if we know that h is greater or equal to each element in l and h is smaller or equal than each element in l' we can put it in between the two:
Lemma lem_lstle_lelst {A} {dto: DecTotalOrder A} : forall h l l',
LstLe h l -> LeLst h l' -> Sorted (l ++ h :: l').
It seems very intuitiv but i get stuck every time in the proof. This is my current attempt:
Lemma lem_lstle_lelst {A} {dto: DecTotalOrder A} : forall h l l',
LstLe h l -> LeLst h l' -> Sorted (l ++ h :: l').
Proof.
intros h l l' H_LstLe.
induction H_LstLe.
- intros. simpl. Search (Sorted (_ :: _)).
unfold LeLst in H. Search (List.Forall _ _).
induction l'.
+ constructor.
+ Search (List.Forall _ _).
constructor.
{ hauto use: List.Forall_inv. }
{ generalize (List.Forall_inv_tail H).
intros.
generalize (List.Forall_inv H).
intros.
generalize (IHl' H0).
intros.
generalize (lem_sorted_tail H2).
intros.
However I get stuck here, because the hypotheses just don't seem strong enough:
1 subgoal
A : Type
dto : DecTotalOrder A
h, a : A
l' : list A
H : List.Forall (fun x : A => leb h x) (a :: l')
IHl' : List.Forall (fun x : A => leb h x) l' -> Sorted (h :: l')
H0 : List.Forall (fun x : A => leb h x) l'
H1 : leb h a
H2 : Sorted (h :: l')
H3 : Sorted l'
______________________________________(1/1)
Sorted (a :: l')
I'd be really glad if someone could give me a hint, maybe something is wrong with my definitions and that is why i can't get on with the proof? Or am I just missing out on some tactics that I could use?
Here is a list of lemmata allready proven about sortedness:
Lemma lem_sorted_tail {A} {dto : DecTotalOrder A}{l x} :
Sorted (x :: l) -> Sorted l.
Lemma lem_sorted_prepend {A} {dto: DecTotalOrder A} : forall x l l',
Sorted((x :: l) ++ l') -> Sorted(l ++ l').
Lemma lem_sort_conc_mid {A} {dto: DecTotalOrder A} : forall x y l,
Sorted (x :: y :: l) -> Sorted (x :: l).
As stated in a comment the Lemma is not provable.
Instead its defintion has to be expanded by adding properties about the sortedness of l
and l':
Lemma lem_lstle_lelst {A} {dto: DecTotalOrder A} : forall h l l',
LstLe h l -> LeLst h l' -> Sorted l -> Sorted l' -> Sorted (l ++ h :: l').
This is possible to prove with the following:
Proof.
intros h l l' H_Lstle_h_l.
induction H_Lstle_h_l.
- intros H_Lelst_h_l' H_Sort_1 H_Sort_2.
simpl;inversion H_Lelst_h_l';sauto.
- intros H_Lelst_h_l' H_Sort_1 H_Sort_2.
generalize (lem_sorted_tail H_Sort_1).
intros H_Sort_l.
generalize (IHH_Lstle_h_l H_Lelst_h_l' H_Sort_l H_Sort_2).
intros H_Sort_l_h_l'.
generalize (lem_sorted_lelst x l H_Sort_1).
intros H_Lelst_x_l.
hauto use: lem_Sorted_prepend_inv.
Qed.
introducing new helper lemmata:
Lemma lem_Sorted_prepend_inv {A} {dto: DecTotalOrder A} :
forall x h l l', leb x h -> Sorted(l ++ h :: l') -> LeLst x l -> Sorted(x::l++ h::l').
Lemma lem_sorted_lelst {A} {dto: DecTotalOrder A} :
forall x l, Sorted(x :: l) -> LeLst x l.
Following The Haskell Road to Logic, Maths and Programming, one can find p.48 Theorem 2.12.1 ¬ ⊤ ≡ ⊥ and its converse ¬ ⊥ ≡ ⊤
The book uses Haskell and assumes
⊥ = False
⊤ = True
which would yield the Agda type theorem : (p q : Bool) → not p ≡ q which is trivial to prove via refl.
However, can one prove the original theorem without assuming 1 and 2?
trying
-- from software foundations (https://plfa.github.io/Negation/)
postulate
excluded-middle : ∀ {A : Set} → A ⊎ ¬ A
theorem : ¬ ⊤ ≡ ⊥
theorem x = {!!}
of course yields no solution, since we can't construct ⊥, so I guess a proof by contradiction is needed? Also, am I correct that this assumes the law of the excluded middle, which is therefore required as an additional postulate?
Agda says:
I'm not sure if there should be a case for the constructor refl,
because I get stuck when trying to solve the following unification
problems (inferred index ≟ expected index):
⊤ ≟ ⊥
when checking that the expression ? has type ⊥
Thanks!
This is provable in plain Agda without postulates. The solution is that ⊤ ≡ ⊥ allows us to turn any proof of ⊤ into a proof of ⊥.
open import Data.Unit
open import Data.Empty
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary
theorem : ¬ (⊤ ≡ ⊥)
theorem eq = subst (λ A → A) eq tt
If ¬ ⊤ ≡ ⊥ is ¬ (⊤ ≡ ⊥), then #Andras Kovacs answer suits for both ¬ ⊤ ≡ ⊥ and ¬ ⊥ ≡ ⊤. If ¬ ⊤ ≡ ⊥ is (¬ ⊤) ≡ ⊥, then the proof requires an equality of types. Usually you should be fine with the proof of existence of isomorphism between ¬ ⊤ and ⊥.
The proof for (¬ ⊤) ≡ ⊥ establishes that ¬ ⊤ is not inhabited.
The proof for (¬ ⊥) ≡ ⊤ then essentially establishes the fact that ¬ ⊥ has only one function, id (hence is isomorphic to all types containing a single element).
All of the following can be constructed using some standard Agda functions, but here the self-sufficient bunch of definitions needed to prove the existence of such isomorphisms. Note False and True are types, not boolean values. Also, extensionality axiom is needed to be able to prove the second theorem, because ¬ ⊥ is a function.
data False : Set where
data True : Set where
tt : True
data _==_ {A : Set} (x : A) : A -> Set where
refl : x == x
false-elim : {A : Set} -> False -> A
false-elim ()
id : {A : Set} -> A -> A
id x = x
const : {A B : Set} -> B -> A -> B
const x _ = x
ap : {A B : Set} -> (A -> B) -> A -> B
ap = id
ap' : {A B : Set} -> A -> (A -> B) -> B
ap' x f = f x
infixl 4 _==_
data Isomorphism {A B : Set} (f : A -> B) (g : B -> A) : Set where
iso : ((x : B) -> f (g x) == id x) ->
((x : A) -> g (f x) == id x) -> Isomorphism f g
Not : Set -> Set
Not A = A -> False
not-True-iso-False : Isomorphism (ap' tt) false-elim
not-True-iso-False = iso (\x -> false-elim {ap' tt (false-elim x) == id x} x)
\not-true -> false-elim (not-true tt)
-- extensionality: if functions produce equal results for all inputs, then the functions are equal
postulate ext : {A B : Set} -> (f g : A -> B) -> ((x : A) -> f x == g x) -> f == g
not-False-iso-True : Isomorphism {Not False} {True} (const tt) (const id)
not-False-iso-True = iso is-true is-not-false where
is-true : (x : True) -> const tt (const {True} (id {Not False})) == id x
is-true tt = refl
is-not-false : (x : Not False) -> const id (const {Not False} tt) == id x
is-not-false x = ext (const id (const {Not False} tt)) x \()
Now, if we define _==_ for any level of type universe, then we can introduce the axiom about type equality: if two types have an isomporphism, then they are equal.
open import Agda.Primitive
data _==_ {a : Level} {A : Set a} (x : A) : A -> Set a where
refl : x == x
postulate iso-is-eq : {A B : Set} {f : A -> B} {g : B -> A} ->
Isomorphism f g -> A == B
not-True-is-False : (Not True) == False
not-True-is-False = iso-is-eq not-True-iso-False
not-False-is-True : (Not False) == True
not-False-is-True = iso-is-eq not-False-iso-True
I'm practicing logical equivalence and I've come across a question that I'm struggling to answer:
Show that (R or P -> R or Q) is equivalent to (not R -> (P -> Q)).
I've examined the truth tables of both implications but the question states that I should use equivalence laws to show that the implications are equivalent.
If anyone could help me out, I would appreciate it.
Thank you.
Intuitive
A formal proof (included below) which only allows one to follow the steps one by one is less useful than a proof that helps us understand why both expressions are equivalent. Consider the first expression:
(R or P) -> (R or Q)
and think about its meaning...
The expression is trivial when R=true, isn't it? Therefore the only information it encloses is that when R=false, P -> (R or Q). But when R=false, (R or Q) = Q. So, the precise meaning of the expression is that when R=false, P -> Q. In other words, not R -> (P -> Q).
Formal
(R or P) -> (R or Q) = not (R or P) or (R or Q) ;X -> Y = not X or Y
= (not R and not P) or (R or Q) ;not (X or Y) = not X or not Y
= ((not R and not P) or R) or Q ;X or (Y or Z) = (X or Y) or Z
= ((not R or R) and (not P or R)) or Q ;(X and Y) or Z = (X or Z) and (Y or Z)
= (not P or R) or Q ;(not X or X) = true
= (R or not P) or Q
= R or (not P or Q)
= R or (P -> Q)
= not (not R) or (P -> Q)
= not R -> (P -> Q) ;not X or Y = X -> Y
I'll illustrate using an example.
H : R -> P -> Q
H0 : R
Subgoal:
(Q -> P) \ / (P -> Q)
so my question is how do I extract out (P->Q). I have R already, but when I do
'apply H in H0', it evaluates everything and gives me Q.
You can do any of:
specialize (H H0).
to replace H with H: P -> Q, or:
pose proof (H H0) as H1
to introduce H1: P -> Q
You can also go forward:
right. exact (H H0).