Defining Unlambda-style tree notation in Coq - binary-tree

Here is a definition of polymorphic binary trees I am using in a Coq project.
Inductive tree { X : Type } : Type :=
| t_a : X -> tree
| t_m : tree -> tree -> tree.
A binary tree of natural numbers ( 1 ( ( 2 3 ) 4 ) ), declared using this definition, would be:
t_m ( t_a 1 ) ( t_m ( t_m ( t_a 2 ) ( t_a 3 ) ) ( t_a 4 ) )
As you can see, the definition becomes unusable very quickly with increasing number of leaves. What I want to do is define an Unlambda-style notation for trees so that I can replace the above with
' 1 ' ' 2 3 4
Is this possible?

I tried to get a solution that used only Coq notations, but couldn't get it to work. I suspect that Coq's extensible parser is not powerful enough to understand the notation you want. There is, however, a poor man's solution that involves dependent types. The idea is to write a parser for that notation and use that parser's type to encode the parser state. The type says that the parser "reads" some token (actually, takes that token as an argument to a function call), and goes into some next state that depends on the token it just read.
There's a small subtlety, though, which is that one cannot write that type using just regular Coq function types, because the number of arguments that function would take would depend on all the arguments it is being applied to. One solution is to use a coinductive type to encode this behavior, declaring a coercion to make it look like a function:
Inductive tree (X : Type) : Type :=
| t_a : X -> tree X
| t_m : tree X -> tree X -> tree X.
Arguments t_a {X} _.
Arguments t_m {X} _ _.
CoInductive tree_builder X : nat -> Type :=
| TbDone : tree X -> tree_builder X 0
| TbRead : forall n, (forall o : option X, tree_builder X match o with
| Some x => n
| None => S (S n)
end) ->
tree_builder X (S n).
Arguments TbDone {X} _.
Arguments TbRead {X} _ _.
(* Destructors for tree_builder *)
Definition case0 {X} (x : tree_builder X 0) : tree X :=
match x with
| TbDone t => t
end.
Definition caseS {X n} (x : tree_builder X (S n)) :
forall o : option X, tree_builder X match o with
| Some x => n
| None => S (S n)
end :=
match x with
| TbRead _ f => f
end.
Definition tb X n := tree_builder X (S n).
(* force is what does the magic here: it takes a tb and coerces it to a
function that may produce another tb, depending on what it is applied to. *)
Definition force X n (x : tb X n) : forall o : option X,
match o with
| Some x =>
match n with
| 0 => tree X
| S n' => tb X n'
end
| None =>
tb X (S n)
end :=
fun o =>
match o return tree_builder X match o with
| Some x => n
| None => S (S n)
end ->
match o with
| Some x => match n with
| 0 => tree X
| S n' => tb X n'
end
| None => tb X (S n)
end
with
| Some x => match n return tree_builder X n -> match n with
| 0 => tree X
| S n' => tb X n'
end
with
| 0 => fun t => case0 t
| S _ => fun t => t
end
| None => fun t => t
end (caseS x o).
Coercion force : tb >-> Funclass.
Our parser, then, is just a term of type tb X 0. As it is usually done, it has to be written in continuation-passing style because of the variable number of arguments.
Fixpoint parser_cont_type X (n : nat) : Type :=
match n with
| 0 => tree X
| S n' => tree X -> parser_cont_type X n'
end.
CoFixpoint parser X n : parser_cont_type X n -> tree_builder X n :=
match n with
| 0 => fun k => TbDone k
| S n' => fun k : tree X -> parser_cont_type X n' =>
TbRead n' (fun o => match o return tree_builder X match o with
| Some _ => n'
| None => S (S n')
end
with
| Some x => parser X n' (k (t_a x))
| None => parser X (S (S n')) (fun (t1 t2 : tree X) => k (t_m t1 t2))
end)
end.
Definition parser' X : tb X 0 :=
parser X 1 (fun t => t).
Next, we can define some extra notation to make this easier to use:
Notation "[ x ]" := (Some x) (at level 0).
Notation "''" := None (at level 0).
Notation "!" := (parser' _) (at level 20).
Here's how one could write your example tree, for instance:
Definition my_tree : tree nat := Eval hnf in ! '' [1] '' '' [2] [3] [4].
Notice the initial ! to start a call to the parser, and the [] that are needed to mark the leaves. I also couldn't get Coq's parser to accept ' as a token on its own. Besides these minor details, however, it is fairly close to what you had.
One problem is that, because the parser is defined using Coq functions, one needs to do a little bit of simplification to get a term that is exactly like the one you had originally. This is why I added the Eval call on the definition. This is probably not as practical as a real notation, and the definition is admittedly a bit tricky, but it could be pretty useful for some cases.
Here's a gist with the entire .v file.
UPDATE: I've written a post with a much simplified version of this technique made more generic.

Related

Coq matrix manipulation

I am trying to use marices in Coq. I found la library that does exactly what I need, but being very new in Coq, I can't figure out a way to prove meaningful properties.
The library is SQIRE, and it defines a matrix as such :
Definition Matrix (m n : nat) := nat -> nat -> C.
Now, There are some working examples in the project such as:
Definition V0 : Vector 2 :=
fun x y => match x, y with
| 0, 0 => C1
| 1, 0 => C0
| _, _ => C0
end.
(so V0 is the column vector (1,0) )
Definition I (n : nat) : Matrix n n :=
(fun x y => if (x =? y) && (x <? n) then C1 else C0).
and
Lemma Mmult00 : Mmult (adjoint V0) V0 = I 1. Proof. solve_matrix. Qed.
So first thing I tried is this :
Definition test : Matrix 2 2 :=
fun x y => match x, y with
| 0, 0 => 0
| 0, 1 => 1
| 1, 0 => 2
| 1, 1 => 3
| _, _ => 0
end.
Definition test2 : Matrix 2 2 :=
fun x y => match x, y with
| 0, 0 => 0
| 0, 1 => 2
| 1, 0 => 4
| 1, 1 => 6
| _, _ => 0
end.
Lemma double : test2 = 2 .* test. Proof. solve_matrix. Qed.
And no luck Here. So I then tried no enumerate the cases :
Lemma testouille : test2 = 2 .* test.
Proof.
autounfold with U_db.
prep_matrix_equality.
assert (x = 0 \/ x = 1 \/ x >= 2)%nat as X.
omega.
destruct X as [X|X].
- { (* x = 0 *)
subst.
assert (y = 0 \/ y = 1 \/ y >= 2)%nat as Y.
omega.
destruct Y as [Y|Y].
- { (* y = 0 *)
subst.
simpl.
field.
}
- {
destruct Y as [Y|Y].
- { (* y = 1 *)
subst.
simpl.
field.
}
- { (* y >= 2 *)
subst. (* I can't operate for each y, recursions ?*)
simpl.
field.
}
}
}
- {
destruct X as [X|X].
- { (* x = 1 *)
subst.
assert (y = 0 \/ y = 1 \/ y >= 2)%nat as Y.
omega.
destruct Y as [Y|Y].
- { (* y = 0 *)
subst.
simpl.
field.
}
- {
destruct Y as [Y|Y].
- { (* y = 1 *)
subst.
simpl.
field.
}
- { (* y >= 2 *)
subst. (* I can't operate for each y, recursions ?*)
simpl.
field.
}
}
}
- { (* x >= 2, I can't operate for each x, recursions ?*)
subst.
simpl.
field.
}
}
Qed.
But this didn't work either, Coq seems to be unable to guess that if x is greater than 1, then test x y is zero. And at this point, I'm a bit short on ideas. Can somebody come to my rescue ?
It looks like solve_matrix just doesn't know what test and test2 are to unfold them.
Here are two possible solutions:
Lemma double : test2 = 2 .* test. Proof. unfold test, test2. solve_matrix. Qed.
Hint Unfold test test2 : U_db.
Lemma double' : test2 = 2 .* test. Proof. solve_matrix. Qed.
For the longer proof, you're going to have to actually destruct y twice so Coq can pattern match on it (you can use omega to solve the other cases). There's also a tactic called destruct_m_eq that will do the work of breaking things down into cases for you. Here's a shorter manual proof of your lemma:
Lemma testouille : test2 = 2 .* test.
Proof.
autounfold with U_db.
prep_matrix_equality.
unfold test, test2.
destruct_m_eq.
all: lca.
Qed.
Relatedly, I recommend the tactics lia and lra for solving integer and real equalities, and the derived tactic lca for complex number equalities. (field seemed to fail in a few instance in your proof.)
For a lighter introduction to QWIRE's matrix library (used by SQIR), I recommend Verified Quantum Computing, though it does make some changes not reflected in the main branch of QWIRE.

Is it possible to use guards in function definition in idris?

In haskell, one could write :
containsTen::Num a => Eq a => [a] -> Bool
containsTen (x : y : xs)
| x + y == 10 = True
| otherwise = False
Is it possible to write something equivalent in Idris, without doing it with ifThenElse (my real case is more complex than the one above)?
Idris does not have pattern guards exactly as in haskell. There is with clause which is syntactically similar (but more powerful as it supports matching in presence of dependent types):
containsTen : Num a => List a -> Bool
containsTen (x :: y :: xs) with (x + y)
| 10 = True
| _ = False
You can take a look at the Idris tutorial section 7 Views and the "with" rule.

Is there a fast algorithm to determine the godel number of a term of a context free language?

Suppose we have a simple grammar specification. There is a way to enumerate terms of that grammar that guarantees that any finite term will have a finite position, by iterating it diagonally. For example, for the following grammar:
S ::= add
add ::= mul | add + mul
mul ::= term | mul * term
term ::= number | ( S )
number ::= digit | digit number
digit ::= 0 | 1 | ... | 9
You can enumerate terms like that:
0
1
0+0
0*0
0+1
(0)
1+0
0*1
0+0*0
00
... etc
My question is: is there a way to do the opposite? That is, to take a valid term of that grammar, say, 0+0*0, and find its position on such enumeration - in that case, 9?
For this specific problem, we can cook up something fairly simple, if we allow ourselves to choose a different enumeration ordering. The idea is basically the one in Every Bit Counts, which I also mentioned in the comments. First, some preliminaries: some imports/extensions, a data type representing the grammar, and a pretty-printer. For the sake of simplicity, my digits only go up to 2 (big enough to not be binary any more, but small enough not to wear out my fingers and your eyes).
{-# LANGUAGE TypeSynonymInstances #-}
import Control.Applicative
import Data.Universe.Helpers
type S = Add
data Add = Mul Mul | Add :+ Mul deriving (Eq, Ord, Show, Read)
data Mul = Term Term | Mul :* Term deriving (Eq, Ord, Show, Read)
data Term = Number Number | Parentheses S deriving (Eq, Ord, Show, Read)
data Number = Digit Digit | Digit ::: Number deriving (Eq, Ord, Show, Read)
data Digit = D0 | D1 | D2 deriving (Eq, Ord, Show, Read, Bounded, Enum)
class PP a where pp :: a -> String
instance PP Add where
pp (Mul m) = pp m
pp (a :+ m) = pp a ++ "+" ++ pp m
instance PP Mul where
pp (Term t) = pp t
pp (m :* t) = pp m ++ "*" ++ pp t
instance PP Term where
pp (Number n) = pp n
pp (Parentheses s) = "(" ++ pp s ++ ")"
instance PP Number where
pp (Digit d) = pp d
pp (d ::: n) = pp d ++ pp n
instance PP Digit where pp = show . fromEnum
Now let's define the enumeration order. We'll use two basic combinators, +++ for interleaving two lists (mnemonic: the middle character is a sum, so we're taking elements from either the first argument or the second) and +*+ for the diagonalization (mnemonic: the middle character is a product, so we're taking elements from both the first and second arguments). More information on these in the universe documentation. One invariant we'll maintain is that our lists -- with the exception of digits -- are always infinite. This will be important later.
ss = adds
adds = (Mul <$> muls ) +++ (uncurry (:+) <$> adds +*+ muls)
muls = (Term <$> terms ) +++ (uncurry (:*) <$> muls +*+ terms)
terms = (Number <$> numbers) +++ (Parentheses <$> ss)
numbers = (Digit <$> digits) ++ interleave [[d ::: n | n <- numbers] | d <- digits]
digits = [D0, D1, D2]
Let's see a few terms:
*Main> mapM_ (putStrLn . pp) (take 15 ss)
0
0+0
0*0
0+0*0
(0)
0+0+0
0*(0)
0+(0)
1
0+0+0*0
0*0*0
0*0+0
(0+0)
0+0*(0)
0*1
Okay, now let's get to the good bit. Let's assume we have two infinite lists a and b. There's two things to notice. First, in a +++ b, all the even indices come from a, and all the odd indices come from b. So we can look at the last bit of an index to see which list to look in, and the remaining bits to pick an index in that list. Second, in a +*+ b, we can use the standard bijection between pairs of numbers and single numbers to translate between indices in the big list and pairs of indices in the a and b lists. Nice! Let's get to it. We'll define a class for Godel-able things that can be translated back and forth between numbers -- indices into the infinite list of inhabitants. Later we'll check that this translation matches the enumeration we defined above.
type Nat = Integer -- bear with me here
class Godel a where
to :: a -> Nat
from :: Nat -> a
instance Godel Nat where to = id; from = id
instance (Godel a, Godel b) => Godel (a, b) where
to (m_, n_) = (m + n) * (m + n + 1) `quot` 2 + m where
m = to m_
n = to n_
from p = (from m, from n) where
isqrt = floor . sqrt . fromIntegral
base = (isqrt (1 + 8 * p) - 1) `quot` 2
triangle = base * (base + 1) `quot` 2
m = p - triangle
n = base - m
The instance for pairs here is the standard Cantor diagonal. It's just a bit of algebra: use the triangle numbers to figure out where you're going/coming from. Now building up instances for this class is a breeze. Numbers are just represented in base 3:
-- this instance is a lie! there aren't infinitely many Digits
-- but we'll be careful about how we use it
instance Godel Digit where
to = fromIntegral . fromEnum
from = toEnum . fromIntegral
instance Godel Number where
to (Digit d) = to d
to (d ::: n) = 3 + to d + 3 * to n
from n
| n < 3 = Digit (from n)
| otherwise = let (q, r) = quotRem (n-3) 3 in from r ::: from q
For the remaining three types, we will, as suggested above, check the tag bit to decide which constructor to emit, and use the remaining bits as indices into a diagonalized list. All three instances necessarily look very similar.
instance Godel Term where
to (Number n) = 2 * to n
to (Parentheses s) = 1 + 2 * to s
from n = case quotRem n 2 of
(q, 0) -> Number (from q)
(q, 1) -> Parentheses (from q)
instance Godel Mul where
to (Term t) = 2 * to t
to (m :* t) = 1 + 2 * to (m, t)
from n = case quotRem n 2 of
(q, 0) -> Term (from q)
(q, 1) -> uncurry (:*) (from q)
instance Godel Add where
to (Mul m) = 2 * to m
to (m :+ t) = 1 + 2 * to (m, t)
from n = case quotRem n 2 of
(q, 0) -> Mul (from q)
(q, 1) -> uncurry (:+) (from q)
And that's it! We can now "efficiently" translate back and forth between parse trees and their Godel numbering for this grammar. Moreover, this translation matches the above enumeration, as you can verify:
*Main> map from [0..29] == take 30 ss
True
We did abuse many nice properties of this particular grammar -- non-ambiguity, the fact that almost all the nonterminals had infinitely many derivations -- but variations on this technique can get you quite far, especially if you are not too strict on requiring every number to be associated with something unique.
Also, by the way, you might notice that, except for the instance for (Nat, Nat), these Godel numberings are particularly nice in that they look at/produce one bit (or trit) at a time. So you could imagine doing some streaming. But the (Nat, Nat) one is pretty nasty: you have to know the whole number ahead of time to compute the sqrt. You actually can turn this into a streaming guy, too, without losing the property of being dense (every Nat being associated with a unique (Nat, Nat)), but that's a topic for another answer...

Quicksort proof using Coq

I am writing a thesis on program verification of the quicksort algorithm using the Coq system. I have defined a quicksort in Coq but my supervisor and myself arn't very comfortable writing the actual proof using tactics. Is there anyone that can help with that section of the coq proof? The following is what we have come up with so far:
Inductive nat : Type :=
| O : nat
| S : nat -> nat.
Check (S (S (S (S O)))).
Definition isZero (n:nat) : bool :=
match n with
O => true
|S p => false
end.
Inductive List: Set :=
| nil: List
| cons: nat -> List -> List.
Fixpoint Concat (L R: List) : List :=
match L with
| nil => R
| cons l ls => cons l (Concat ls R)
end.
Fixpoint Less (n m:nat) :=
match m with
O => false
|S q => match n with
O => true
|S p => Less p q
end
end.
Fixpoint Lesseq (n m:nat) :=
match n with
O => true
|S p => match m with
O => false
|S q => Lesseq p q
end
end.
Fixpoint Greatereq (n m:nat) :=
match n with
O => true
|S p => match m with
O => true
|S q => Greatereq p q
end
end.
Fixpoint Allless (l:List) (n:nat) : List :=
match l with
nil => nil
|cons m ls => match Less n m with
false => Allless ls n
|true => cons m (Allless ls n)
end
end.
Fixpoint Allgeq (l:List) (n:nat) : List :=
match l with
nil => nil
|cons m ls => match Greatereq n m with
false => Allgeq ls n
|true => cons m (Allgeq ls n)
end
end.
Fixpoint qaux (n:nat) (l:List) : List :=
match n with
O => nil
|S p => match l with
nil => nil
|cons m ls => let low := Allless ls m in
(let high := Allgeq ls m in
Concat (qaux p low) (cons m (qaux p high)))
end
end.
Fixpoint length (l:List) : nat :=
match l with
nil => O
|cons m ls => S (length ls)
end.
Fixpoint Quicksort (l:List) : List := qaux (length l) l.
I know for a proof to work we need a lemma or a theorem but then I am not sure where to start after that. Thanks for the help :)
There are many nice theorems you can prove about your code.
Define a function pos that maps a number and a list to the index of the number in the list.
Th 1: For all lists S, and a, b in S, (a <= b) <-> (pos a (sort S)) <= (pos b (sort S)). This would be a correctness theorem for the sort function.
Th 2: (sort (sort S)) = sort S
Define the functions min and max to find the minimum and maximum elements of the list S.
Th 3: The pos of the minimal element of the sorted list is 0.
Th 4: The pos of the maximal element of the reverse of the sorted list is 0.
Abstract a predicate out of your sort routine, so that you can pass it as an argument.
Th 5: Show that (sort <= S) = (reverse (sort >= S))
etc. You can continue this ad infinitum. It's lots of fun. :-)
View your problem as a problem of "symbolic testing". Write a function that tests that your output is correct, and then show that all combinations of your initial code and your testing function work as intended.
Here is my favorite testing function for a sorting algorithm on your datatype.
Fixpoint sorted (l : List) : bool :=
match l with cons a l' =>
match l' with cons b l'' =>
if Lesseq a b then sorted l' else false
| nil => true
end
| nil => true
end.
then you can start a proof in the following way:
Lemma Quicksort_sorted : forall l, sorted (Quicksort l) = true.
But you will have to prove many intermediate lemmas before getting to proving the main one. So formal proof is really like testing, except that you ensure full coverage of the test.

Recursive addition in F# using

I'm trying to implement the following recursive definition for addition in F#
m + 0 := m
m + (n + 1) := (m + n) + 1
I can't seem to get the syntax correct, The closest I've come is
let rec plus x y =
match y with
| 0 -> x;
| succ(y) -> succ( plus(x y) );
Where succ n = n + 1. It throws an error on pattern matching for succ.
I'm not sure what succ means in your example, but it is not a pattern defined in the standard F# library. Using just the basic functionality, you'll need to use a pattern that matches any number and then subtract one (and add one in the body):
let rec plus x y =
match y with
| 0 -> x
| y -> 1 + (plus x (y - 1))
In F# (unlike e.g. in Prolog), you can't use your own functions inside patterns. However, you can define active patterns that specify how to decompose input into various cases. The following takes an integer and returns either Zero (for zero) or Succ y for value y + 1:
let (|Zero|Succ|) n =
if n < 0 then failwith "Unexpected!"
if n = 0 then Zero else Succ(n - 1)
Then you can write code that is closer to your original version:
let rec plus x y =
match y with
| Zero -> x
| Succ y -> 1 + (plus x y)
As Tomas said, you can't use succ like this without declaring it. What you can do is to create a discriminated union that represents a number:
type Number =
| Zero
| Succ of Number
And then use that in the plus function:
let rec plus x y =
match y with
| Zero -> x
| Succ(y1) -> Succ (plus x y1)
Or you could declare it as the + operator:
let rec (+) x y =
match y with
| Zero -> x
| Succ(y1) -> Succ (x + y1)
If you kept y where I have y1, the code would work, because the second y would hide the first one. But I think doing so makes the code confusing.
type N = Zero | Succ of N
let rec NtoInt n =
match n with
| Zero -> 0
| Succ x -> 1 + NtoInt x
let rec plus x y =
match x with
| Zero -> y
| Succ n -> Succ (plus n y)
DEMO:
> plus (Succ (Succ Zero)) Zero |> NtoInt ;;
val it : int = 2
> plus (Succ (Succ Zero)) (Succ Zero) |> NtoInt ;;
val it : int = 3
let rec plus x y =
match y with
| 0 -> x
| _ -> plus (x+1) (y-1)

Resources