Coq, meta programming, generate fresh variable to create a Prop - metaprogramming

I have my own type Mytype, that defines a kind of formula. I'd like to translate this formula into a Coq proposition Prop. To do so, I feel like I would need some kind of Meta Programming, that would let me write forall <variable 15>, <variable 15> /\ <variable (15+1)>.
Here is a MWE that I'd like to translate:
Inductive Myprop : Type :=
| MTrue
| MFalse
| MVar (_ : nat)
| MAnd (_ : Myprop) (_ : Myprop)
| MOr (_ : Myprop) (_ : Myprop)
| MForall (_ : nat) (_ : Myprop)
.
(* Exemple *)
Eval simpl in MForall 42 (MForall 42 (MOr (MVar 42) (MVar 50))).
Fixpoint translate (myprop : Myprop) : Prop :=
match myprop with
| MTrue => True
| MFalse => False
| MVar n => (* ???? Variable n ??? *)
| MAnd a b => (translate a) /\ (translate b)
| MOr a b => (translate a) \/ (translate b)
| MForall n a => forall (* ???? Variable n ??? *), (translate a)
end.
Thank you!

As gallais suggests, you can augment your translate function with a context lookup function:
Fixpoint translate (lookup : nat -> Prop) (myprop : Myprop) : Prop :=
match myprop with
| MTrue => True
| MFalse => False
| MVar n => lookup n
| MAnd a b => (translate lookup a) /\ (translate lookup b)
| MOr a b => (translate lookup a) \/ (translate lookup b)
| MForall n a => forall p : Prop,
translate (fun n' => if Nat.eqb n' n then p else lookup n') a
end.
Eval compute in translate _ (MForall 42 (MForall 42 (MOr (MVar 42) (MVar 50)))).
(* Prop -> forall p0 : Prop, p0 \/ ?lookup 50 *)
Another approach is to use HOAS (Higher-Order Abstract Syntax), and let your bindings be Gallina bindings:
Inductive Myprop : Type :=
| MTrue
| MFalse
| MVar (_ : Prop)
| MAnd (_ : Myprop) (_ : Myprop)
| MOr (_ : Myprop) (_ : Myprop)
| MForall (_ : Prop -> Myprop)
.
(* Exemple *)
Eval simpl in MForall (fun p42 => MForall (fun p42 => MOr (MVar p42) (MVar ?[p50]))).
(* ?[p50] denotes a fresh evar named "p50" *)
Fixpoint translate (myprop : Myprop) : Prop :=
match myprop with
| MTrue => True
| MFalse => False
| MVar P => P
| MAnd a b => (translate a) /\ (translate b)
| MOr a b => (translate a) \/ (translate b)
| MForall P => forall p : Prop, translate (P p)
end.
Eval simpl in translate (MForall (fun p42 => MForall (fun p42 => MOr (MVar p42) (MVar ?[p50])))).
(* forall p p0 : Prop, p0 \/ ?p50#{p43:=p; p42:=p0} *)

Related

List coalgebra translating code from Haskell to SML

I'm trying to translate this piece of code in Haskell that describes List anamorphism but can't quite get it to work.
The final three lines are supposed to generate a function count which given an int will produce an int list [n, n-1, ..., 1]
Haskell code:
data Either a b = Left a | Right b
type List_coalg u x = u -> Either () (x, u)
list ana :: List_coalg u x -> u -> [x]
list_ana a = ana where
ana u = case a u of
Left _ -> []
Right (x, l) -> x : ana l
count = list_ana destruct_count
destruct_count 0 = Left ()
destruct_count n = Right (n, n-1)
What I have so far:
type ('a, 'b) List_coalg = 'a -> (unit, 'a*'b) Either
fun list_ana (f : ('a, 'b) List_coalg) : 'a -> 'b list =
let
fun ana a : 'b list =
case f a of
Left () => []
| Right (x, l) => x :: ana l
in
ana
end
fun destruct_count 0 = Left ()
| destruct_count n = Right (n, n-1)
val count = list_ana destruct_count
I get the following error:
catamorphism.sml:22.7-24.35 Error: case object and rules do not agree [UBOUND match]
rule domain: (unit,'b * 'a) Either
object: (unit,'a * 'b) Either
in expression:
(case (f a)
of Left () => nil
| Right (x,l) => x :: ana l)
Not sure how to fix this as I am not super proficient in SML.
As you mentioned in the comments, the type parameters got mixed up. With a bit of renaming for comparison:
type List_coalg a b = a -> Either () (b, a) -- (b, a)
type ('a, 'b) List_coalg = 'a -> (unit, 'a*'b) Either (* ('a * 'b) *)
which leads to a mismatch after pattern-matching on the pair:
Right (x, l) -> x : ana l
-- x :: b
-- l :: a
Right (x, l) => x :: ana l
(* x : 'a *)
(* l : 'b *)

Data type for arithmetic expressions with let bindings in haskell

Data type for arithmetic expressions with let bindings in haskell
Here's a variant of the original Expr type that adds variables (V) and let bindings (Let).
data Expr = C Float | V String
| Let [(String, Expr)] Expr
| Expr :+ Expr | Expr :- Expr
| Expr :* Expr | Expr :/ Expr
To help write evaluate, you may want to start with a function that does variable substitution:
data Expr = C Float | V String
| Let [(String, Expr)] Expr
| Expr :+ Expr | Expr :- Expr
| Expr :* Expr | Expr :/ Expr
deriving Show
-- | #sub var value e# replaces variables named #var# with the value #value#
-- wherever anywhere that variable occurs in expression #e#.
sub :: String -> Expr -> Expr -> Expr
-- "let x = y in x" = y
sub v1 value (V v2) | v1 == v2 = value
-- "let x = y in z" = z
sub _ _ e#(V _) = e
-- Constants are unaffected
sub _ _ c#(C _) = c
-- For operators, apply #sub a b# recursively to the operands.
sub a b (e1 :+ e2) = (sub a b e1) :+ (sub a b e2)
sub a b (e1 :- e2) = (sub a b e1) :- (sub a b e2)
sub a b (e1 :* e2) = (sub a b e1) :* (sub a b e2)
sub a b (e1 :/ e2) = (sub a b e1) :/ (sub a b e2)
-- The variable is shadowed by a let binding, so only substitute
-- into the bindings, and leave the body expression unmodified.
sub a b (Let bindings e) | bindingsContains a bindings =
Let (subIntoBindings a b bindings) e
-- Apply #sub a b# recursively to the body of the let expression.
sub a b (Let bindings body) =
Let (subIntoBindings a b bindings) (sub a b body)
bindingsContains :: String -> [(String, Expr)] -> Bool
bindingsContains x bindings =
Data.Maybe.isJust $ Data.List.find ((== x) . fst) bindings
subIntoBindings :: String -> Expr -> [(a, Expr)] -> [(a, Expr)]
subIntoBindings a b bindings = (fmap . fmap) (sub a b) bindings

Pattern-Matching mixed with guards

I wanted to define the function:
accumulate_list' :: Num a => [a] -> ( a -> a -> a ) -> a
accumulate_list' l f
| [] f = 0
| (x:xs) f = f x (accumulate_list xs f)
but it doesn't compile, complaining that x, xs, x, xs, are Not in scope.
Trying to achieve the same result, I have defined this function
accumulate_list :: Num a => [a] -> ( a -> a -> a ) -> a
accumulate_list [] f = 0
accumulate_list (x:xs) f = f x $ accumulate_list xs f
it compiles well, and does like sum does on a list if the functgion passed in parameter is (+). Yes, I finally found that indeed what I wanted to achieve was already existing in Prelude as the sum function.
However, I don't understand why the first version with mixed guards and pattern matching doesn't compile. What is the problem ?
It is because guards are basically a boolean expression. They have to evaluate to either True or False. Something like this should typecheck:
accumulate_list' :: (Eq a, Num a) => [a] -> ( a -> a -> a ) -> a
accumulate_list' l f
| l == [] = 0
| otherwise = undefined -- fill out undefined
It's also worth mentioning that since pattern guards were added to Haskell 2010, you're allowed to mix patterns and guards like so:
accumulate_list' :: (Eq a, Num a) => [a] -> ( a -> a -> a ) -> a
accumulate_list' l f
| [] <- l = 0 --pattern for the empty list case
| 10 < 5 = 10 --arbitrary regular guard just because
| (x:xs) <- l = undefined --pattern for the non-empty case
Using what #Sibi's answer provided, I've completed it so as to provide entire working code example:
accumulate_list' :: (Eq a ,Num a) => [a] -> ( a -> a -> a ) -> a
accumulate_list' l f
| l == [] = 0
| otherwise = f x $ accumulate_list xs f
where (x:xs) = l

Standard way to zip two lists using custom comparator functions

If often need to zip two lists, discarding non matching elements (where "matching" is definied by comparing parts of the elements of the lists). For example:
let as = [(1,"a"), (2,"b"), (4,"c")]
let bs = [(2,"a"), (3,"b"), (4,"c"), (5, "d")]
zipWithAdjust (fst) (fst) as bs
-- ~> [((2,"b"),(2,"a")), ((4,"c"),(4,"c"))]
I implemented zipWithAdjust as follows:
zipWithAdjust :: (Ord c, Show a, Show b, Show c) => (a -> c) -> (b -> c) -> [a] -> [b] -> [(a,b)]
zipWithAdjust cmpValA cmpValB (a:as) (b:bs)
| cmpValA a == cmpValB b = (a,b) : zipWithAdjust cmpValA cmpValB as bs
| cmpValA a > cmpValB b = zipWithAdjust cmpValA cmpValB (a:as) bs
| cmpValA a < cmpValB b = zipWithAdjust cmpValA cmpValB as (b:bs)
zipWithAdjust _ _ _ _ = []
It works fine, but I have a feeling that there is a standard way to do such zip. I found Data.Align and this SO Question but can't figure out how to use it for my use case.
Is there a standard way to do this (using library functions)? Is it Data.Align? If so, how do I implement the above function using Data.Align?
Edit: Changed the < case to get implementation matching with example.
As far as I know, there's no such function. However, you could make your function more general by using (a -> b -> Ordering) instead of two additional functions:
zipWithAdjust :: (a -> b -> Ordering) -> [a] -> [b] -> [(a,b)]
zipWithAdjust cmp (a:as) (b:bs)
| ord == LT = zipWithAdjust cmp as (b:bs)
| ord == GT = zipWithAdjust cmp (a:as) (bs)
| ord == EQ = (a,b) : zipWithAdjust cmp as bs
where ord = cmp a b
zipWithAdjust _ _ _ = []
result = zipWithAdjust (\x y -> compare (fst x) (fst y)) [(1,"a"), (2,"b"), (4,"c")] [(2,"a"), (3,"b"), (4,"c"), (5, "d")]
However, I wouldn't call this zip anymore, but something like compareMerge or similar.
You might like Data.Map's intersection capabilities. It's slightly less capable in some ways and more capable in others. For example:
> let as = fromList [(1,"a"), (2,"b"), (4,"c")]; bs = fromList [(2,"a"), (3,"b"), (4,"c"), (5, "d")]
> intersectionWith (,) as bs
fromList [(2,("b","a")),(4,("c","c"))]
I would say it's a bit more idiomatic to say
zipWithAdjust cmpA cmpB (a:as) (b:bs) =
case cmpA a `compare` cmpB b of
EQ -> (a, b) : zipWithAdjust cmpA cmpB as bs
GT -> zipWithAdjust cmpA cmpB (a:as) bs
LT -> zipWithAdjust cmpA cmpB as (b:bs)
zipWithAdjust _ _ _ _ = []
It would certainly be faster, since it reduces the number of times you have to calculate cmpA a and cmpB b. This isn't truly a zip since you are filtering at the same time, and also offsetting in your GT and LT cases. I would say that this solution is perfectly fine as it is, there isn't a need to implement it using standard functions.
edit: using These a b type from Data.These (used by Data.Align), with this:
ordzipBy :: (Ord t) => (a -> t) -> (b -> t) -> [a] -> [b] -> [These a b]
ordzipBy f g a#(x:t) b#(y:r) = case compare (f x) (g y) of
LT -> This x : ordzipBy f g t b
GT -> That y : ordzipBy f g a r
EQ -> These x y : ordzipBy f g t r
ordzipBy _ _ a [] = map This a
ordzipBy _ _ [] b = map That b
we can express three set operations as:
diffBy :: (Ord t) => (a -> t) -> (b -> t) -> [a] -> [b] -> [a]
meetBy :: (Ord t) => (a -> t) -> (b -> t) -> [a] -> [b] -> [(a, b)]
joinBy :: (Ord t) => (a -> t) -> (a->a->a) -> [a] -> [a] -> [a]
diffBy f g xs ys = [x | This x <- ordzipBy f g xs ys]
meetBy f g xs ys = [(x,y) | These x y <- ordzipBy f g xs ys]
joinBy f h xs ys = mergeThese h `map` ordzipBy f f xs ys
what you describe is meetBy, i.e. set intersection operation, with the two ordered lists seen as sets.
The ability of a compiler to efficiently compile these definitions is another question though. The three set functions hand-coded along the lines of ordzipBy might run faster.
ordzipBy f g is compatible with align, and [] with nil, but the type machinery involved in making it happen is above my pay grade. :) Also, it's not clear to me whether the law align (f <$> xs) (g <$> ys) = bimap f g <$> align xs ys would make sense at all because mapping the functions f and g can very well change the mutual ordering of elements of xs and ys.
The two problems (the types, and the law) are related: the parts of data recovered by selector functions for ordering purposes serve as positions, as shape, yet are part of the original data. (cf. instance Alternative ZipList in Haskell?).
update: see if the following works as you expected.
{-# LANGUAGE InstanceSigs, DatatypeContexts #-}
import Data.These
import Data.Align
newtype Ord a => ZL a b = ZL {unzl :: [(a,b)]}
deriving (Eq, Show)
instance Ord a => Functor (ZL a) where
fmap f (ZL xs) = ZL [(k, f v) | (k,v)<-xs]
instance Ord a => Align (ZL a) where
nil = ZL []
align :: (ZL a b) -> (ZL a c) -> (ZL a (These b c))
align (ZL a) (ZL b) = ZL (g a b) where
g a#((k,x):t) b#((n,y):r) = case compare k n of
LT -> (k, This x ) : g t b
GT -> (n, That y) : g a r
EQ -> (k, These x y) : g t r
g a [] = [(k, This x) | (k,x) <- a]
g [] b = [(n, That y) | (n,y) <- b]
diffBy :: (Ord t) => (a -> t) -> (b -> t) -> [a] -> [b] -> [a]
meetBy :: (Ord t) => (a -> t) -> (b -> t) -> [a] -> [b] -> [(a, b)]
joinBy :: (Ord t) => (a -> t) -> (a->a->a) -> [a] -> [a] -> [a]
diffBy f g xs ys = catThis . map snd . unzl
$ align (ZL [(f x,x) | x<-xs]) (ZL [(g y,y) | y<-ys])
meetBy f g xs ys = catThese . map snd . unzl
$ align (ZL [(f x,x) | x<-xs]) (ZL [(g y,y) | y<-ys])
joinBy f h xs ys = map (mergeThese h . snd) . unzl
$ align (ZL [(f x,x) | x<-xs]) (ZL [(f y,y) | y<-ys])
Infinite lists aren't handled well though, while the hand-coded functions can obviously quite easily be made to handle such cases correctly:
*Main> diffBy id id [1..5] [4..9]
[1,2,3]
*Main> diffBy id id [1..5] [4..]
[1,2,3Interrupted.
*Main> meetBy id id [1,3..10] [2,5..20]
[(5,5)]
*Main> joinBy id const [1,3..10] [2,5..20]
[1,2,3,5,7,8,9,11,14,17,20]

Coq string sort lemmas

I have a string sort function defined as below and want to prove a lemma
sort_str_list_same below. I am not Coq expert, I tried to solve it using induction, but could not solve it. Please help me solving it. Thanks,
Require Import Ascii.
Require Import String.
Notation "x :: l" := (cons x l) (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x , .. , y ]" := (cons x .. (cons y nil) ..).
Fixpoint ble_nat (n m : nat) : bool :=
match n with
| O => true
| S n' =>
match m with
| O => false
| S m' => ble_nat n' m'
end
end.
Definition ascii_eqb (a a': ascii) : bool :=
if ascii_dec a a' then true else false.
(** true if s1 <= s2; s1 is before/same as s2 in alphabetical order *)
Fixpoint str_le_gt_dec (s1 s2 : String.string)
: bool :=
match s1, s2 with
| EmptyString, EmptyString => true
| String a b, String a' b' =>
if ascii_eqb a a' then str_le_gt_dec b b'
else if ble_nat (nat_of_ascii a) (nat_of_ascii a')
then true else false
| String a b, _ => false
| _, String a' b' => true
end.
Fixpoint aux (s: String.string) (ls: list String.string)
: list String.string :=
match ls with
| nil => s :: nil
| a :: l' => if str_le_gt_dec s a
then s :: a :: l'
else a :: (aux s l')
end.
Fixpoint sort (ls: list String.string) : list String.string :=
match ls with
| nil => nil
| a :: tl => aux a (sort tl)
end.
Notation "s1 +s+ s2" := (String.append s1 s2) (at level 60, right associativity) : string_scope.
Lemma sort_str_list_same: forall z1 z2 zm,
sort (z1 :: z2 :: zm) =
sort (z2 :: z1 :: zm).
Proof with o.
Admitted.
Your lemma is equivalent to forall z1 z2 zm, aux z1 (aux z2 zm) = aux z2 (aux z1 zm). Here's how you can prove a similar theorem, for an arbitrary type with an order relation. To use it in your case, you just have to prove the given hypothesis. Note that the Coq standard library defines some sorting functions and proves lemmas about them, so you may be able to solve your problem without having to prove too many things.
Require Import Coq.Lists.List.
Section sort.
Variable A : Type.
Variable comp : A -> A -> bool.
Hypothesis comp_trans :
forall a b c, comp a b = true ->
comp b c = true ->
comp a c = true.
Hypothesis comp_antisym :
forall a b, comp a b = true ->
comp b a = true ->
a = b.
Hypothesis comp_total :
forall a b, comp a b = true \/ comp b a = true.
Fixpoint insert (a : A) (l : list A) : list A :=
match l with
| nil => a :: nil
| a' :: l' => if comp a a' then a :: a' :: l'
else a' :: insert a l'
end.
Lemma l1 : forall a1 a2 l, insert a1 (insert a2 l) = insert a2 (insert a1 l).
Proof.
intros a1 a2 l.
induction l as [|a l IH]; simpl.
- destruct (comp a1 a2) eqn:E1.
+ destruct (comp a2 a1) eqn:E2; trivial.
rewrite (comp_antisym _ _ E1 E2). trivial.
+ destruct (comp a2 a1) eqn:E2; trivial.
destruct (comp_total a1 a2); congruence.
- destruct (comp a2 a) eqn:E1; simpl;
destruct (comp a1 a) eqn:E2; simpl;
destruct (comp a1 a2) eqn:E3; simpl;
destruct (comp a2 a1) eqn:E4; simpl;
try rewrite E1; trivial;
try solve [rewrite (comp_antisym _ _ E3 E4) in *; congruence];
try solve [destruct (comp_total a1 a2); congruence].
+ assert (H := comp_trans _ _ _ E3 E1). congruence.
+ assert (H := comp_trans _ _ _ E4 E2). congruence.
Qed.
Section sort.

Resources