I have a simple data type with all nullary constructors and wish to define a partial order for it, including a Relation.Binary.IsPartialOrder _≡_.
My use case: the type is the type of sorts in an abstract syntax tree (statement, expression, literal, item), and i want a constructor of the AST which effectively upcasts a term (item ≤ statement, expression ≤ statement, literal ≤ expression).
data Sort : Set where stmt expr item lit : Sort
So far i have this:
data _≤_ : Rel Sort lzero where
refl : {a : Sort} → a ≤ a
trans : {a b c : Sort} → a ≤ b → b ≤ c → a ≤ c
expr≤stmt : expr ≤ stmt
item≤stmt : item ≤ stmt
lit≤expr : lit ≤ expr
I can define isPreorder but have no idea how to define antisym:
open import Agda.Primitive
open import Data.Empty using (⊥)
open import Data.Unit using (⊤)
open import Relation.Binary
open import Relation.Binary.PropositionalEquality using (_≡_)
import Relation.Binary.PropositionalEquality as PropEq
module Core.Sort where
data Sort : Set where
stmt expr item lit : Sort
data _≤_ : Rel Sort lzero where
refl : {a : Sort} → a ≤ a
trans : {a b c : Sort} → a ≤ b → b ≤ c → a ≤ c
lit≤expr : lit ≤ expr
expr≤stmt : expr ≤ stmt
item≤stmt : item ≤ stmt
≤-antisymmetric : Antisymmetric _≡_ _≤_
≤-antisymmetric =
λ { refl _ → PropEq.refl;
_ refl → PropEq.refl;
(trans refl x≤y) y≤x → ≤-antisymmetric x≤y y≤x;
(trans x≤y refl) y≤x → ≤-antisymmetric x≤y y≤x;
x≤y (trans refl y≤x) → ≤-antisymmetric x≤y y≤x;
x≤y (trans y≤x refl) → ≤-antisymmetric x≤y y≤x;
x≤z (trans z≤y (trans y≤w w≤x)) → _ }
I'm not sure what to do in the last clause (and all further clauses like it), and in any case this is cumbersome.
Am i missing a more convenient method to define an arbitrary partial order?
Notice that, for any given x and y, whenever x ≤ y is provable, there are infinitely many such proofs. E.g., stmt ≤ stmt is proved by refl and by trans refl refl and so forth. This may (but probably doesn't) explain why it's troublesome (and maybe impossible) to prove ≤-antisymmetric.
In any case, the following definition of "less than or equal", _≼_, has the property that whenever x ≼ y is provable, there is exactly one proof of it. Bonus: I can prove antisym for it.
-- x ≺ y = x is contiguous to and less than y
data _≺_ : Rel Sort lzero where
lit≺expr : lit ≺ expr
expr≺stmt : expr ≺ stmt
item≺stmt : item ≺ stmt
-- x ≼ y = x is less than or equal to y
data _≼_ : Rel Sort lzero where
refl : {a : Sort} → a ≼ a
trans : {a b c : Sort} → a ≺ b → b ≼ c → a ≼ c
≼-antisymmetric : Antisymmetric _≡_ _≼_
≼-antisymmetric refl _ = PropEq.refl
≼-antisymmetric _ refl = PropEq.refl
≼-antisymmetric (trans lit≺expr _) (trans lit≺expr _) = PropEq.refl
≼-antisymmetric (trans lit≺expr refl) (trans expr≺stmt (trans () _))
≼-antisymmetric (trans lit≺expr (trans expr≺stmt _)) (trans expr≺stmt (trans () _))
≼-antisymmetric (trans lit≺expr (trans expr≺stmt _)) (trans item≺stmt (trans () _))
≼-antisymmetric (trans expr≺stmt _) (trans expr≺stmt _) = PropEq.refl
≼-antisymmetric (trans expr≺stmt (trans () _)) (trans lit≺expr _)
≼-antisymmetric (trans expr≺stmt (trans () _)) (trans item≺stmt _)
≼-antisymmetric (trans item≺stmt (trans () _)) (trans lit≺expr _)
≼-antisymmetric (trans item≺stmt (trans () _)) (trans _ _)
Related
I am pretty new to Haskell and I am trying to write a function neighbours :: Int -> Metric a -> Point a -> [Point a] -> [Point a] such that neighbours k d p xs returns a list of the k nearest neighbours, in distance order, according to metric d to point p in the list xs of points. My code is
type Point a = (a, a)
type Metric a = Point a -> Point a -> Double
type Tuple a = (Double, Point a)
create:: Metric a -> Point a -> [Point a] -> [Tuple a] -> [Tuple a]
create d p (x:xs) ys | length xs == 0 = sort(((d p x), x) : ys)
| otherwise = create d p xs (((d p x), x) : ys)
takeP:: Tuple a -> Point a
takeP (_,p) = p
pList:: [Tuple a] ->[Point a]-> [Point a]
pList (x:xs) ys | length xs == 0 = reverse (takeP x : ys)
| otherwise = pList xs (takeP x : ys)
neighbours :: Int -> Metric a -> Point a -> [Point a] -> [Point a]--
neighbours k d p xs = take k (pList (create d p xs []) [])
But I am getting an error on sort which is:
* No instance for (Ord a) arising from a use of `sort'
Possible fix:
add (Ord a) to the context of
the type signature for:
create :: forall a.
Metric a -> Point a -> [Point a] -> [Tuple a] -> [Tuple a]
* In the expression: sort (((d p x), x) : ys)
In an equation for `create':
create d p (x : xs) ys
| length xs == 0 = sort (((d p x), x) : ys)
| otherwise = create d p xs (((d p x), x) : ys)
I used type Point a = (Int, Int) at first and it was working fine but in the specification it is required that Point is type Point a = (a, a) which caused my error. The other problem is that I cannot change the function types so I can't just add (Ord a) as proposed.
Is there a way to sort the Tuples' list by the first variable without encountering errors?
In your create function, you make use of sort :: Ord a => [a] -> [a]:
… = sort (((d p x), x) : ys)
this thus means that type of objects that we are sorting, in this case Tuple a, needs to be an instance of the Ord typeclass. A 2-tuple is an instance of the Ord typeclass, if both the type of the items are instances of Ord as well, so in this case Double and Point a. Since Point a is also a 2-tuple, but of two as, this thus means that Tuple a is an instance of Ord, if a is an instance of Ord. You thus should add a type constraint:
create :: Ord a => Metric a -> Point a -> [Point a] -> [Tuple a] -> [Tuple a]
create d p (x:xs) ys | length xs == 0 = sort(((d p x), x) : ys)
| otherwise = create d p xs (((d p x), x) : ys)
The create function makes use of some anti-patterns like using length, which takes linear time. You can in fact rewrite this to sorting a mapping:
create :: Ord a => Metric a -> Point a -> [Point a] -> [Tuple a]
create d p = sort . map f
where f x = (d p x, x)
This removes the ys parameter, which here only seems to be used as a accumulator.
If you wish to only sort on the first item of the 2-tuple, you can make use of sortOn :: Ord b => (a -> b) -> [a] -> [a]:
create :: Metric a -> Point a -> [Point a] -> [Tuple a]
create d p = sortOn fst . map f
where f x = (d p x, x)
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.
I'm trying to find a way to prove a couple of set theory-based problems in Agda, but I'm having a hard time defining the function range.
I took the definition of Subset from Proving decidability of subset in Agda and built on top of it. This is what I got so far:
open import Data.Bool as Bool using (Bool; true; false; T; _∨_; _∧_)
open import Data.Unit using (⊤; tt)
open import Level using (Level; _⊔_; 0ℓ) renaming (suc to lsuc)
open import Data.Product using (_×_) renaming (_,_ to ⟨_,_⟩)
Subset : ∀ {α} (A : Set α) -> Set _
Subset A = A → Bool
_∈_ : ∀ {α} {A : Set α} → A → Subset A → Set
a ∈ p = T (p a)
Relation : ∀ {α β} (A : Set α) (B : Set β) → Set (α ⊔ β)
Relation A B = Subset (A × B)
Range : ∀ {A B : Set} → Relation A B → Subset B
Range = ?
_⊆_ : ∀ {A : Set} → Subset A → Subset A → Set
A ⊆ B = ∀ x → x ∈ A → x ∈ B
wholeSet : ∀ (A : Set) → Subset A
wholeSet _ = λ _ → true
∀subset⊆set : ∀ {A : Set} {sub : Subset A} → sub ⊆ wholeSet A
∀subset⊆set = λ _ _ → tt
_∩_ : ∀ {A : Set} → Subset A → Subset A → Subset A
A ∩ B = λ x → (A x) ∧ (B x)
⊆-range-∩ : ∀ {A B : Set}
(F G : Relation A B)
→ Range (F ∩ G) ⊆ (Range F ∩ Range G)
⊆-range-∩ f g = ?
The problem is that Range takes as an input a function of type A × B → Bool and must return a function B → Bool such that a value B is true iff there exists a value A × B which is true in the initial function. Basically, I would need to iterate through all values of A to know whether B is in the range of the relation. Something impossible to do, isn't it?
There must be surely a better way to implement Range, doesn't it?
Here is the implementation I suggest :
open import Data.Unit
open import Data.Product renaming (_,_ to ⟨_,_⟩)
open import Data.Sum
open import Function
Change the definition of Subset to go to Set instead of Bool. I know this might be controversial, but in my experience this has always been the way to go, and also this is how subsets are implemented in the standard library. (By the way, if you are interested to see the implementation in the standard library, it is in the file Relation/Unary.agda). I also removed the levels of universe since you didn't use them in your later definitions, which led me to clean up the types of the module.
Subset : Set → Set₁
Subset A = A → Set
The definition of membership is changed accordingly.
_∈_ : ∀ {A} → A → Subset A → Set
a ∈ P = P a
Relation : ∀ A B → Set₁
Relation A B = Subset (A × B)
The range becomes then very natural : b is in the range of R if their exists an a such as R of a and b holds.
Range : ∀ {A B} → Relation A B → Subset B
Range R b = ∃ (R ∘ ⟨_, b ⟩) -- equivalent to ∃ \a → R ⟨ a , b ⟩
_⊆_ : ∀ {A} → Subset A → Subset A → Set
A ⊆ B = ∀ x → x ∈ A → x ∈ B
Not much to say about the wholeset
wholeSet : ∀ A → Subset A
wholeSet _ _ = ⊤
∀subset⊆set : ∀ {A sub} → sub ⊆ wholeSet A
∀subset⊆set _ _ = tt
_∩_ : ∀ {A} → Subset A → Subset A → Subset A
(A ∩ B) x = x ∈ A × x ∈ B
The proof of range inclusion is done very naturally with this definition.
⊆-range-∩ : ∀ {A B} {F G : Relation A B} → Range (F ∩ G) ⊆ (Range F ∩ Range G)
⊆-range-∩ _ ⟨ a , ⟨ Fab , Gab ⟩ ⟩ = ⟨ ⟨ a , Fab ⟩ , ⟨ a , Gab ⟩ ⟩
I also took the liberty to add the corresponding property about union.
_⋃_ : ∀ {A} → Subset A → Subset A → Subset A
(A ⋃ B) x = x ∈ A ⊎ x ∈ B
⋃-range-⊆ : ∀ {A B} {F G : Relation A B} → (Range F ⋃ Range G) ⊆ Range (F ⋃ G)
⋃-range-⊆ _ (inj₁ ⟨ a , Fab ⟩) = ⟨ a , inj₁ Fab ⟩
⋃-range-⊆ _ (inj₂ ⟨ a , Gab ⟩) = ⟨ a , inj₂ Gab ⟩
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 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