I'm trying to build an equality predicate returning sumbool instead of bool for a simple type:
Inductive state_type : Set := State : nat -> nat -> state_type.
Here's a working solution, which splits into subgoals based on whether the fields match (one at a time).
Definition state_eq : forall (s1 s2 : state_type), {s1 = s2} + {s1 <> s2}.
intros.
destruct s1 as [a1 b1]. destruct s2 as [a2 b2].
destruct (eq_nat_dec a1 a2) as [Aeq | Aneq]. destruct (eq_nat_dec b1 b2) as [Beq | Bneq].
left. congruence.
right. congruence.
right. congruence.
Defined.
The proof is readable, but I'd like a more direct proof using refine:
Definition state_eq2 : forall (s1 s2 : state_type), {s1 = s2} + {s1 <> s2}.
refine (fun (s1 s2 : state_type) =>
match s1, s2 with State a1 b1, State a2 b2 =>
if (eq_nat_dec a1 a2)
then if (eq_nat_dec b1 b2)
then left _ _
else right _ _
else right _ _
end).
Defined.
The three return values end up as subgoals, but the context for all of them loses the eq_nat_dec hypotheses, rendering them unprovable. How can I retain these hypotheses to finish the proof?
It seems that if ... then ... else is what's losing those hypotheses. Replacing it with an explicit match preserves the hypotheses, allowing congruence to finish off the proof as before:
Definition state_eq : forall (s1 s2 : state_type), {s1 = s2} + {s1 <> s2}.
refine (fun (s1 s2 : state_type) =>
match s1, s2 with State a1 b1, State a2 b2 =>
match (eq_nat_dec a1 a2) with
| left _ => match (eq_nat_dec b1 b2) with
| left _ => left _ _
| right _ => right _ _
end
| right _ => right _ _
end
end); congruence.
Defined.
Related
Given the declaration of the swapIfAdjacent function I need to do the following:
swapIfAdjacent :: Eq a => a -> a -> [a] -> [a]
If either a,b or b,a are consecutive items, then for the first and only occurrence the order of these two items should be swapped.
My code so far:
swapIfAdjacent _ _ [] = []
swapIfAdjacent a b (x:xs) | a `elem` xs && b `elem` xs
= if adjacent a b xs then swap a b (x:xs) else (x:xs)
| otherwise = error "not adjacent"
where
swap _ _ [] = []
swap a b (x:xs)
| a == x = b : swap a b xs
| b == x = a : swap a b xs
| otherwise = x : swap a b xs
The adjacent function that I'm using is already defined as follows:
adjacent :: Eq a => a -> a -> [a] -> Bool
adjacent a b (x:y:etc) | x == a
= y == b
| x == b
= y == a
| otherwise
= adjacent a b (y:etc)
adjacent _ _ _ = False
I have observed that according to my implementation the swapping procedure occurs for every element and not only for the first ones and also the following error:
swapIfAdjacent 'a' 'a' "banana" --> banana
while
swapIfAdjacent 'b' 'b' "banana" --> error "not adjacent"
Both of the above examples should produce as output the whole list and not errors. I assume the error has to do with the fact that 'b' is appearing in the list only once "banana" while 'a' multiple times.
You are doing a lot of unnecessary work here. Here's an implementation to consider.
swapIfAdjacent a b (x:y:xys) | (a, b) == (x, y) || (b, a) == (x, y) = y:x:xys
| otherwise = x : swapIfAdjacent a b (y:xys)
swapIfAdjacent _ _ xys = xys
You don't need any of elem, adjacent or swap.
I am hand-writing a parser for a simple regular expression engine.
The engine supports a .. z | * and concatenation and parentheses
Here is the CFG I made:
exp = concat factor1
factor1 = "|" exp | e
concat = term factor2
factor2 = concat | e
term = element factor3
factor3 = * | e
element = (exp) | a .. z
which is equal to
S = T X
X = "|" S | E
T = F Y
Y = T | E
F = U Z
Z = *| E
U = (S) | a .. z
For alternation and closure, I can easily handle them by looking ahead and choose a production based on the token. However, there is no way to handle concatenation by looking ahead cause it is implicit.
I am wondering how can I handle concatenation or is there anything wrong with my grammar?
And this is my OCaml code for parsing:
type regex =
| Closure of regex
| Char of char
| Concatenation of regex * regex
| Alternation of regex * regex
(*| Epsilon*)
exception IllegalExpression of string
type token =
| End
| Alphabet of char
| Star
| LParen
| RParen
| Pipe
let rec parse_S (l : token list) : (regex * token list) =
let (a1, l1) = parse_T l in
let (t, rest) = lookahead l1 in
match t with
| Pipe ->
let (a2, l2) = parse_S rest in
(Alternation (a1, a2), l2)
| _ -> (a1, l1)
and parse_T (l : token list) : (regex * token list) =
let (a1, l1) = parse_F l in
let (t, rest) = lookahead l1 in
match t with
| Alphabet c -> (Concatenation (a1, Char c), rest)
| LParen ->
(let (a, l1) = parse_S rest in
let (t1, l2) = lookahead l1 in
match t1 with
| RParen -> (Concatenation (a1, a), l2)
| _ -> raise (IllegalExpression "Unbalanced parentheses"))
| _ ->
let (a2, rest) = parse_T l1 in
(Concatenation (a1, a2), rest)
and parse_F (l : token list) : (regex * token list) =
let (a1, l1) = parse_U l in
let (t, rest) = lookahead l1 in
match t with
| Star -> (Closure a1, rest)
| _ -> (a1, l1)
and parse_U (l : token list) : (regex * token list) =
let (t, rest) = lookahead l in
match t with
| Alphabet c -> (Char c, rest)
| LParen ->
(let (a, l1) = parse_S rest in
let (t1, l2) = lookahead l1 in
match t1 with
| RParen -> (a, l2)
| _ -> raise (IllegalExpression "Unbalanced parentheses"))
| _ -> raise (IllegalExpression "Unknown token")
For a LL grammar the FIRST sets are the tokens that are allowed as first token for a rule. To can construct them iteratively till you reach a fixed point.
a rule starting with a token has that token in its FIRST set
a rule starting with a term has the FIRST set of that term in its FIRST set
a rule T = A | B has the union of FIRST(A) and FIRST(B) as FIRST set
Start with step 1 and then repeat steps 2 and 3 until the FIRST sets reach a fixed point (don't change). Now you have the true FIRST sets for your grammar and can decide every rule using the lookahead.
Note: In your code the parse_T function doesn't match the FIRST(T) set. If you look at for example 'a|b' then is enters parse_T and the 'a' is matched by the parse_F call. The lookahead then is '|' which matches epsilon in your grammar but not in your code.
I've found myself repeating a pattern over and over again, and I'd like to abstract it. I'm fairly confident that coq is sufficiently expressive to capture the pattern, but I'm having a bit of trouble figuring out how to do so. I'm defining a programming language, which has mutually recursive inductive datatypes representing the syntactic terms:
Inductive Expr : Set :=
| eLambda (x:TermVar) (e:Expr)
| eVar (x:TermVar)
| eAscribe (e:Expr) (t:IFType)
| ePlus (e1:Expr) (e2:Expr)
| ... many other forms ...
with DType : Set :=
| tArrow (x:TermVar) (t:DType) (c:Constraint) (t':DType)
| tInt
| ... many other forms ...
with Constraint : Set :=
| cEq (e1:Expr) (e2:Expr)
| ...
Now, there are a number of functions that I need to define over these types. For example, I'd like a function to find all of the free variables, a function to perform substitution, and a function to pull out the set of all constraints. These functions all have the following form:
Fixpoint doExpr (e:Expr) := match e with
(* one or two Interesting cases *)
| ...
(* lots and lots of boring cases,
** all of which just recurse on the subterms
** and then combine the results in the same way
*)
| ....
with doIFType (t:IFType) := match t with
(* same structure as above *)
with doConstraint (c:Constraint) := match c with
(* ditto *)
For example, to find free variables, I need to do something interesting in the variable cases and the cases that do binding, but for everything else I just recursively find all of the free variables of the subexpressions and then union those lists together. Similarly for the function that produces a list of all of the constraints. The substitution case is a little bit more tricky, because the result types of the three functions are different, and the constructors used to combine the subexpressions are also different:
Variable x:TermVar, v:Expr.
Fixpoint substInExpr (e:Expr) : **Expr** := match e with
(* interesting cases *)
| eLambda y e' =>
if x = y then eLambda y e' else eLambda y (substInExpr e')
| eVar y =>
if x = y then v else y
(* boring cases *)
| eAscribe e' t => **eAscribe** (substInExpr e') (substInType t)
| ePlus e1 e2 => **ePlus** (substInExpr e1) (substInExpr e2)
| ...
with substInType (t:Type) : **Type** := match t with ...
with substInConstraint (c:Constraint) : **Constraint** := ...
.
Writing these functions is tedious and error prone, because I have to write out all of the uninteresting cases for each function, and I need to make sure I recurse on all of the subterms. What I would like to write is something like the following:
Fixpoint freeVars X:syntax := match X with
| syntaxExpr eVar x => [x]
| syntaxExpr eLambda x e => remove x (freeVars e)
| syntaxType tArrow x t1 c t2 => remove x (freeVars t1)++(freeVars c)++(freeVars t2)
| _ _ args => fold (++) (map freeVars args)
end.
Variable x:TermVar, v:Expr.
Fixpoint subst X:syntax := match X with
| syntaxExpr eVar y => if y = x then v else eVar y
| syntaxExpr eLambda y e => eLambda y (if y = x then e else (subst e))
| syntaxType tArrow ...
| _ cons args => cons (map subst args)
end.
The key to this idea is the ability to generally apply a constructor to some number of arguments, and to have some kind of "map" that that preserves the type and number of arguments.
Clearly this pseudocode doesn't work, because the _ cases just aren't right. So my question is, is it possible to write code that is organized this way, or am I doomed to just manually listing out all of the boring cases?
Here's another way, though it's not everyone's cup of tea.
The idea is to move recursion out of the types and the evaluators, parameterizing it instead, and turning your expression values into folds. This offers convenience in some ways, but more effort in others -- it's really a question of where you end up spending the most time. The nice aspect is that evaluators can be easy to write, and you won't have to deal with mutually recursive definitions. However, some things that are simpler the other way can become brain-twisters in this style.
Require Import Ssreflect.ssreflect.
Require Import Ssreflect.ssrbool.
Require Import Ssreflect.eqtype.
Require Import Ssreflect.seq.
Require Import Ssreflect.ssrnat.
Inductive ExprF (d : (Type -> Type) -> Type -> Type)
(c : Type -> Type) (e : Type) : Type :=
| eLambda (x:nat) (e':e)
| eVar (x:nat)
| eAscribe (e':e) (t:d c e)
| ePlus (e1:e) (e2:e).
Inductive DTypeF (c : Type -> Type) (e : Type) : Type :=
| tArrow (x:nat) (t:e) (c':c e) (t':e)
| tInt.
Inductive ConstraintF (e : Type) : Type :=
| cEq (e1:e) (e2:e).
Definition Mu (f : Type -> Type) := forall a, (f a -> a) -> a.
Definition Constraint := Mu ConstraintF.
Definition DType := Mu (DTypeF ConstraintF).
Definition Expr := Mu (ExprF DTypeF ConstraintF).
Definition substInExpr (x:nat) (v:Expr) (e':Expr) : Expr := fun a phi =>
e' a (fun e => match e return a with
(* interesting cases *)
| eLambda y e' =>
if (x == y) then e' else phi e
| eVar y =>
if (x == y) then v _ phi else phi e
(* boring cases *)
| _ => phi e
end).
Definition varNum (x:ExprF DTypeF ConstraintF nat) : nat :=
match x with
| eLambda _ e => e
| eVar y => y
| _ => 0
end.
Compute (substInExpr 2 (fun a psi => psi (eVar _ _ _ 3))
(fun _ phi =>
phi (eLambda _ _ _ 1 (phi (eVar _ _ _ 2)))))
nat varNum.
Compute (substInExpr 1 (fun a psi => psi (eVar _ _ _ 3))
(fun _ phi =>
phi (eLambda _ _ _ 1 (phi (eVar _ _ _ 2)))))
nat varNum.
Here is a way to go, but it does not give very readable code: use tactics.
Let's say I have a language with many constructors of various arity, and I want to apply a specific goal only to the case given by constructor aaa, and I want to traverse all the other constructors, to get down to the aaa's that may appear under them. I can do the following:
Say you want to define a function A -> B (A is the type of the language), you will need to keep track of what case you are in,
so you should define a phantom type over A, reducing to B.
Definition phant (x : A) : Type := B.
I suppose that the union function has type B -> B -> B and that you have a default value in B, called empty_B
Ltac generic_process f acc :=
match goal with
|- context [phan (aaa _)] => (* assume aaa has arith 1 *)
intros val_of_aaa_component; exact process_this_value val_of_aaa_component
| |- _ =>
(* This should be used when the next argument of the current
constructor is in type A, you want to process recursively
down this argument, using the function f, and keep this result
in the accumulator. *)
let v := fresh "val_in_A" in
intros v; generic_process f (union acc (f v))
(* This clause will fail if val_in_A is not in type A *)
| |- _ => let v := fresh "val_not_in_A" in
(* This should be used when the next argument of the current
constructor is not in type A, you want to ignore it *)
intros v; generic_process f acc
| |- phant _ =>
(* this rule should be used at the end, when all
the arguments of the constructor have been used. *)
exact acc
end.
Now, you define the function by a proof. Let's say the function is called process_aaa.
Definition process_aaa (x : A) : phant x.
fix process_aaa 1.
(* This adds process_add : forall x:A, phant x. in the context. *)
intros x; case x; generic_process process_aaa empty_B.
Defined.
Note that the definition of generic_process only mention one constructor by name, aaa, all others
are treated in a systematic way. We use the type information to detect those sub-components in which we want to perform a recursive descent. If you have several mutually inductive types, you can add arguments to the generic_process function to indicate which function will be used for each type and have more clauses, one for each argument of each type.
Here is a test of this idea, where the language has 4 constructors, values to be processed are the ones that appear in the constructor var and the type nat is also used in another constructor (c2). We use the type of lists of natural numbers as the type B, with nil as the empty and singleton lists as result when encountering variables. The function collects all occurrences of var.
Require Import List.
Inductive expr : Type :=
var : nat -> expr
| c1 : expr -> expr -> expr -> expr
| c2 : expr -> nat -> expr
| c3 : expr -> expr -> expr
| c4 : expr -> expr -> expr
.
Definition phant (x : expr) : Type := list nat.
Definition union := (#List.app nat).
Ltac generic_process f acc :=
match goal with
|- context[phant (var _)] => exact (fun y => y::nil)
| |- _ => let v := fresh "val_in_expr" in
intros v; generic_process f (union acc (f v))
| |- _ => let v := fresh "val_not_in_expr" in
intros v; generic_process f acc
| |- phant _ => exact acc
end.
Definition collect_vars : forall x : expr, phant x.
fix collect_vars 1.
intros x; case x; generic_process collect_vars (#nil nat).
Defined.
Compute collect_vars (c1 (var 0) (c2 (var 4) 1)
(c3 (var 2) (var 3))).
The last computation returns a list containing values 0 4 2 and 3 as expected, but not 1, which did not occur inside a var constructor.
My homework task is to group two tuples in a list if the second element of the first tuple is the same as the first element of the second tuple. Then, if the first tuple is (a, b) and the second is (b, c), the tuple (a, c) must be added to the result list.
I wrote first function wich takes element with one tuple and second list with many tuples and compare each to each.
this one works correcly:
c1 = ("a","x")
d1 = [ ("x","b"), ("z","c"), ("x","b"), ("z","c")
, ("x","b"), ("z","c"), ("x","b"), ("z","c") ]
getByOne c1 a1 = filter (/=[])
[ if (fst (last(take n a1))) == (snd c1)
then [((fst c1), (snd (last(take n a1))))]
else [] | n <- [1..(length a1) ] ]
output:
[ [("a","b")], [("a","b")], [("a","b")], [("a","b")] ]
But the problems is that I can't throw in if then and else statement just simple tuple, so I create a new list. In the end of this "workaround" i am getting list in list in list and so on. Also if output list was bigger, there were be more lists in lists.
Is there any way to pass out only tuple or empty tuple or i should somehow group theses lists ?
You can flatten the result using
concat :: [[a]] -> [a]
then you don't even need to filter (/=[]) - by the way, the condition (/= []) is more idiomatically written not . null, since the null test doesn't impose an Eq constraint on its argument (you already have one here, so it's just a matter of idiom).
Further, last (take n a1) is just the n-th element of a1 if 1 <= n <= length a1. Since you have that restriction imposed, that can more succinctly be expressed as a1 !! (n-1)
Then you have structurally
getByOne c1 a1 = concat $ [something c1 (a1 !! i) | i <- [0 .. length a1 - 1]]
(I have shifted indices to index by i), which is clearer and more efficiently expressed as
getByOne c1 a1 = concat $ map (something c1) a1
If you prefer a list comprehension to map, you can also write that as
getByOne c1 a1 = concat [something c1 x | x <- a1]
which in your case, using the ability to pattern-match in alist-comprehension generator, gives us
getByOne (f,s) a1 = concat [ if a == s then [(f,b)] else [] | (a,b) <- a1]
which is much shorter and more readable. Instead of using if condition then [element] else [] and concat, even nicer is to use a condition in the list comprehension,
getByOne (f,s) list = [(f,b) | (a,b) <- list, a == s]
which is short and clear.
[1..(length a1)] can be written [1 .. length a1]
[ if (fst (last(take n a1))) == (snd c1)
then [((fst c1), (snd (last(take n a1))))]
else [] | n <- [1..(length a1) ] ]
can be written
[ if fst lastElement == snd c1
then [(fst c1, snd lastElement)]
else [] | n <- [1 .. length a1 ]
, let lastElement = last (take n a1) ]
Then, instead of using the list index to go through it, use the list directly:
[ if x == snd c1
then [(fst c1, y)]
else [] | (x, y) <- a1 ]
Then, instead of using a list to represent the existence or not of a solution, use Maybe:
import Data.Maybe
c1 = ("a","x")
d1 = [ ("x","b"), ("z","c"), ("x","b"), ("z","c")
, ("x","b"), ("z","c"), ("x","b"), ("z","c") ]
getByOne c1 a1 = catMaybes
[ if x == snd c1
then Just (fst c1, y)
else Nothing | (x, y) <- a1 ]
Better yet, use a guard and get rid of the if then else:
getByOne (a, b) a1 = [ (a, d) | (c, d) <- a1
, b == c ]
Alternatively, if you want to use filter, you first filter the list of matching tuples, then build the corresponding results with map:
getByOne (a, b) a1 = map (\(_, c) -> (a, c))
. filter (\(c, _) -> b == c)
$ a1
which simplifies into
getByOne (a, b) = map (\(_, c) -> (a, c))
. filter (\(c, _) -> b == c)
let's say I have
type t = A of int | B of int
let xx = A(2);;
let yy = A(3);;
and I want to test if the constructors of xx and yy are equal,
is there an easy way to do this ? Instead of having to
match xx with
A _ ->
(match yy with A _ -> true | B _ -> false)
| B _ ->
(match yy with A _ -> false | B _ -> true);;
which gets quite messy when there many constructors on a type
You can rewrite the above to, somewhat simpler:
match xx, yy with
| A _, A _
| B _, B _ -> true
| (A _ | B _), _ -> false
but I'm not aware of a solution without enumerating all the constructors.
This is possible, sort of, through the Obj module. Analyzing objects through the Obj functions, if done properly, won't crash your program; but you need to be careful if you want to get meaningful results.
let equal_constructors (x : 'a) (y : 'a) =
let r = Obj.repr x and s = Obj.repr y in
if Obj.is_int r && Obj.is_int s then (Obj.obj r : int) = (Obj.obj s : int) else
if Obj.is_block r && Obj.is_block s then Obj.tag r = Obj.tag s else
false
When called on values of a variant type (not a polymorphic variant type), this function returns true if the two values both have the same zero-argument constructor or both have the same 1-or-more-argument constructor, and false otherwise. The type system won't prevent you from instanciating equal_constructors at other types; you'll get a true or false return value but not necessarily a meaningful one.
Another way of doing this that can work well is to create another type that corresponds to the tags, and use that type.
type t = A of int | B of int
module Tag = struct type t = A | B end
let to_tag = function A _ -> Tag.A | B _ -> Tag.B
let tags_are_equal x y =
to_tag x = to_tag y