I want to write a function to transform regular lambda expression to DeBrujin style with data struct defined by GADT style.
{-# Language GADTs, StandaloneDeriving,ScopedTypeVariables #-}
module DeBrujin where
import Debug.Trace
import Data.List as L
data Apply
data Abstract
data Variable
data LambdaTerm a where
Var :: String -> LambdaTerm Variable
Abs :: String -> LambdaTerm a -> LambdaTerm Abstract
App :: LambdaTerm Abstract -> LambdaTerm a -> LambdaTerm Apply
instance Show (LambdaTerm a) where
show (Var v) = v
show (Abs s t) = "λ" ++ s ++ "." ++ show t
show (App t1 t2) = "(" ++ show t1 ++ ")" ++ "(" ++ show t2 ++ ")"
t1 = App (Abs "x" (Var "x")) (Var "y")
t2 = Abs "x" (Abs "y" (Var "x"))
data LambdaIndex a where
VarI :: String -> LambdaIndex Variable
AbsI :: String -> LambdaIndex a -> LambdaIndex Abstract
AppI :: LambdaIndex Abstract -> LambdaIndex a -> LambdaIndex Apply
BoundI :: Int -> LambdaIndex Variable
instance Show (LambdaIndex a) where
show (VarI v) = v
show (AbsI s t) = "λ." ++ show t
show (AppI t1 t2) = "(" ++ show t1 ++ ")" ++ "(" ++ show t2 ++ ")"
show (BoundI i) = show i
t1' = AppI (AbsI "x" (BoundI 0)) (VarI "y")
type Env = [String]
transform :: Env -> LambdaTerm a -> LambdaIndex a
transform e (Var v) = case L.findIndex (v==) e of
Just i -> BoundI i
Nothing -> VarI v
transform e (Abs s t) = AbsI s (transform (s:e) t)
transfrom e ((App t1 t2)::LambdaTerm Apply) = AppI trans1 trans2
where
trans1 = (transform e t1)
trans2 = (transform e t2)
function tranform gets LambdaTerm to LambdaIndex, But on calling transform [] t1 the interpreter gives
*** Exception: DeBrujin.hs:(43,1)-(47,50):
Non-exhaustive patterns in function transform
I'm confused, LambdaTerm has only three constructors.
I obtained
*DeBrujin> transform [] t1
(λ.0)(y)
after a small fix
transform :: Env -> LambdaTerm a -> LambdaIndex a
transform e (Var v) = case L.findIndex (v==) e of
Just i -> BoundI i
Nothing -> VarI v
transform e (Abs s t) = AbsI s (transform (s:e) t)
transform e (App t1 t2) = AppI trans1 trans2
where
trans1 = (transform e t1)
trans2 = (transform e t2)
The issues were
a typo, as already pointed out in the comments above;
a redundant type annotation, which can not be used with GADT (apparently).
To identify the issues, I simply loaded the file with warnings enabled (-Wall), and saw the messages:
Pattern match(es) are non-exhaustive
In an equation for `transform':
Patterns not matched:
[] (App _ _)
(_:_) (App _ _)
|
42 | transform e (Var v) = case L.findIndex (v==) e of
| ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^...
and
Top-level binding with no type signature:
transfrom :: [String] -> LambdaTerm Apply -> LambdaIndex Apply
|
47 | transfrom e ((App t1 t2)::LambdaTerm Apply) = AppI trans1 trans2
pointing out the missing case in transform, and an independent transfrom without a signature.
I'd recommend you also turn all warnings on and check out all the other messages. None of them points towards a serious issue, but it's a good habit to clean up the code so that it raises no warnings anyway.
Related
I have this AST data structure
data AST = Integer Int
| Let String AST AST
| Plus AST AST
| Minus AST AST
| Times AST AST
| Variable String
| Boolean Bool
| If AST AST AST
| Lambda String AST Type Type
| Application AST AST
| And AST AST
| Or AST AST
| Quot AST AST
| Rem AST AST
| Negate AST
| Eq AST AST
| Leq AST AST
| Geq AST AST
| Neq AST AST
| Lt AST AST
| Gt AST AST
and this evaluation code:
eval :: AST -> AST
eval = cata go where
go :: ASTF (AST) -> AST
go (LetF var e e') = eval $ substVar (var, e) e'
go (PlusF (Integer n) (Integer m)) = Integer (n + m)
go (MinusF (Integer n) (Integer m)) = Integer (n - m)
go (TimesF (Integer n) (Integer m)) = Integer (n * m)
go (QuotF (Integer n) (Integer m)) = Integer (quot n m)
go (RemF (Integer n) (Integer m)) = Integer (rem n m)
go (IfF (Boolean b) e e') = if b then e else e'
go (ApplicationF (Lambda var e _ _) e') = eval $ substVar (var, e') e
go (AndF (Boolean b) (Boolean b')) = Boolean (b && b')
go (OrF (Boolean b) (Boolean b')) = Boolean (b || b')
go (NegateF (Boolean b)) = Boolean (not b)
go (EqF e e') = Boolean (e == e')
go (NeqF e e') = Boolean (e /= e')
go (LeqF (Integer n) (Integer m)) = Boolean (n <= m)
go (GeqF (Integer n) (Integer m)) = Boolean (n >= m)
go (LtF (Integer n) (Integer m)) = Boolean (n < m)
go (GtF (Integer n) (Integer m)) = Boolean (n > m)
go astf = embed astf
I feel like there should be away to remove the explicit recursion for 'let' and application, but I'm not sure exactly which recursion scheme I should reach for. Which recursion scheme(s) can be used to remove recursion in this case and similar cases and do you have any good ways of identifying situations where said recursion scheme is applicable?
eval isn't directly expressible as a catamorphism because eval (Let x e e') applies eval to subst (x, eval e) e', which is not a subterm of Let x e e' (e or e'). Instead, consider the composition of eval and substitution. If you generalize substitution subst to substitute many variables at once with substs, then you can get the following equation:
(eval . substs s) (Let x e e')
= eval (Let x (substs s e) (substs s e'))
= (eval . subst (x, (eval . substs s) e) . substs s) e'
-- by (subst xe . substs s) = substs (xe : s)
= (eval . substs ((x, (eval . substs s) e) : s)) e'
where we do have a function of the form (eval . substs _) applied to both subterms e and e'. In order to account for the parameter of substs, you can use cata with an F-algebra where the carrier is a function ASTF (Sub -> AST) -> Sub -> AST, then you get to pass a different substitution Sub to each subterm.
{-# LANGUAGE TemplateHaskell, TypeFamilies #-}
import Data.Functor.Foldable (cata)
import Data.Functor.Foldable.TH (makeBaseFunctor)
import Data.Maybe (fromJust)
type Id = String
data AST
= Let Id AST AST
| Var Id
| Int Int
| Plus AST AST
type Sub = [(Id, AST)]
makeBaseFunctor ''AST
evalSubsts :: AST -> Sub -> AST
evalSubsts = cata go where
go (LetF x e e') s = e' ((x, e s) : s)
go (VarF x) s = fromJust (lookup x s)
go (IntF n) _ = Int n
go (PlusF e e') s =
let (Int n, Int m) = (e s, e' s) in
Int (n + m)
-- Or this:
-- go (PlusF e e') = liftA2 plus e e'
-- where plus (Int n) (Int m) = Int (n + m)
eval :: AST -> AST
eval e = evalSubsts e []
Another way to think of evalSubsts is as an evaluator using an environment, mapping variables to values. Then to bind a variable, rather than to do a substitution, is just to insert its value in the environment, which gets looked up once you reach a Var node.
Continuing on the evalSubsts approach from #li-yao-xia, let's try to add lambdas and applications to our language. We start by extending AST:
data AST
...
| Lam Id AST
| App AST AST
But, how do we write our LamF case in evalSubst?
go (LamF x e) s = ???
We want our lambdas to be statically (lexically) scoped, so we need to keep around the environment s, but we also can't possibly apply an environment to e yet because we don't know what the value for x should be. We're in a bind!
The solution here is to recognize that, while AST is a great representation for our input, it is not a great representation for the output. Indeed, it's a bit of a coincidence that input Ints and output Ints both happen to share the same structure, and for lambdas, perhaps they shouldn't. So, we can make a new output representation:
data Val
= IntV Int
| LamV (Val -> Val)
type Sub = [(Id, Val)]
The key here is that LamV is a function, not simply some data. With this, we can finish our definition of evalSubsts:
evalSubsts :: AST -> Sub -> Val
evalSubsts = cata go where
go (LetF x e e') s = e' ((x, e s) : s)
go (VarF x) s = fromJust (lookup x s)
go (IntF n) _ = IntV n
go (LamF x e) s = LamV $ \xVal -> e ((x, xVal) : s)
go (AppF lam e) s =
let (LamV f) = lam s in f (e s)
go (PlusF e e') s =
let (IntV n, IntV m) = (e s, e' s) in
IntV (n + m)
One can interpret the lambda calculus in Haskell:
data Expr = Var String | Lam String Expr | App Expr Expr
data Value a = V a | F (Value a -> Value a)
interpret :: [(String, Value a)] -> Expr -> Value a
interpret env (Var x) = case lookup x env of
Nothing -> error "undefined variable"
Just v -> v
interpret env (Lam x e) = F (\v -> interpret ((x, v):env) e)
interpret env (App e1 e2) = case interpret env e1 of
V _ -> error "not a function"
F f -> f (interpret env e2)
How could the above interpreter be extended to the lambda-mu calculus? My guess is that it should use continuations for interpreting the additional constructs in this calculus. (15) and (16) from the Bernardi&Moortgat paper are the kind of translations I expect.
It is possible since Haskell is Turing-complete, but how?
Hint: See the comment on page 197 on this research paper for the intuitive meaning of the mu binder.
Here's a mindless transliteration of the reduction rules from the paper, using #user2407038's representation (as you'll see, when I say mindless, I really do mean mindless):
{-# LANGUAGE DataKinds, KindSignatures, GADTs #-}
{-# LANGUAGE StandaloneDeriving #-}
import Control.Monad.Writer
import Control.Applicative
import Data.Monoid
data TermType = Named | Unnamed
type Var = String
type MuVar = String
data Expr (n :: TermType) where
Var :: Var -> Expr Unnamed
Lam :: Var -> Expr Unnamed -> Expr Unnamed
App :: Expr Unnamed -> Expr Unnamed -> Expr Unnamed
Freeze :: MuVar -> Expr Unnamed -> Expr Named
Mu :: MuVar -> Expr Named -> Expr Unnamed
deriving instance Show (Expr n)
substU :: Var -> Expr Unnamed -> Expr n -> Expr n
substU x e = go
where
go :: Expr n -> Expr n
go (Var y) = if y == x then e else Var y
go (Lam y e) = Lam y $ if y == x then e else go e
go (App f e) = App (go f) (go e)
go (Freeze alpha e) = Freeze alpha (go e)
go (Mu alpha u) = Mu alpha (go u)
renameN :: MuVar -> MuVar -> Expr n -> Expr n
renameN beta alpha = go
where
go :: Expr n -> Expr n
go (Var x) = Var x
go (Lam x e) = Lam x (go e)
go (App f e) = App (go f) (go e)
go (Freeze gamma e) = Freeze (if gamma == beta then alpha else gamma) (go e)
go (Mu gamma u) = Mu gamma $ if gamma == beta then u else go u
appN :: MuVar -> Expr Unnamed -> Expr n -> Expr n
appN beta v = go
where
go :: Expr n -> Expr n
go (Var x) = Var x
go (Lam x e) = Lam x (go e)
go (App f e) = App (go f) (go e)
go (Freeze alpha w) = Freeze alpha $ if alpha == beta then App (go w) v else go w
go (Mu alpha u) = Mu alpha $ if alpha /= beta then go u else u
reduceTo :: a -> Writer Any a
reduceTo x = tell (Any True) >> return x
reduce0 :: Expr n -> Writer Any (Expr n)
reduce0 (App (Lam x u) v) = reduceTo $ substU x v u
reduce0 (App (Mu beta u) v) = reduceTo $ Mu beta $ appN beta v u
reduce0 (Freeze alpha (Mu beta u)) = reduceTo $ renameN beta alpha u
reduce0 e = return e
reduce1 :: Expr n -> Writer Any (Expr n)
reduce1 (Var x) = return $ Var x
reduce1 (Lam x e) = reduce0 =<< (Lam x <$> reduce1 e)
reduce1 (App f e) = reduce0 =<< (App <$> reduce1 f <*> reduce1 e)
reduce1 (Freeze alpha e) = reduce0 =<< (Freeze alpha <$> reduce1 e)
reduce1 (Mu alpha u) = reduce0 =<< (Mu alpha <$> reduce1 u)
reduce :: Expr n -> Expr n
reduce e = case runWriter (reduce1 e) of
(e', Any changed) -> if changed then reduce e' else e
It "works" for the example from the paper: with
example 0 = App (App t (Var "x")) (Var "y")
where
t = Lam "x" $ Lam "y" $ Mu "delta" $ Freeze "phi" $ App (Var "x") (Var "y")
example n = App (example (n-1)) (Var ("z_" ++ show n))
I can reduce example n to the expected result:
*Main> reduce (example 10)
Mu "delta" (Freeze "phi" (App (Var "x") (Var "y")))
The reason I put scare quotes around "works" above is that I have no intuition about the λμ calculus so I don't know what it should do.
Note: this is only a partial answer since I'm not sure how to extend the interpreter.
This seems like a good use case for DataKinds. The Expr datatype is indexed on a type which is named or unnamed. The regular lambda constructs produce named terms only.
{-# LANGUAGE GADTs, DataKinds, KindSignatures #-}
data TermType = Named | Unnamed
type Var = String
type MuVar = String
data Expr (n :: TermType) where
Var :: Var -> Expr Unnamed
Lam :: Var -> Expr Unnamed -> Expr Unnamed
App :: Expr Unnamed -> Expr Unnamed -> Expr Unnamed
and the additional Mu and Name constructs can manipulate the TermType.
...
Name :: MuVar -> Expr Unnamed -> Expr Named
Mu :: MuVar -> Expr Named -> Expr Unnamed
How about something like the below. I don't have a good idea on how to traverse Value a, but at least I can see it evaluates example n into MuV.
import Data.Maybe
type Var = String
type MuVar = String
data Expr = Var Var
| Lam Var Expr
| App Expr Expr
| Mu MuVar MuVar Expr
deriving Show
data Value a = ConV a
| LamV (Value a -> Value a)
| MuV (Value a -> Value a)
type Env a = [(Var, Value a)]
type MuEnv a = [(MuVar, Value a -> Value a)]
varScopeErr :: Var -> Value a
varScopeErr v = error $ unwords ["Out of scope λ variable:", show v]
appErr :: Value a
appErr = error "Trying to apply a non-lambda"
muVarScopeErr :: MuVar -> (Value a -> Value a)
muVarScopeErr alpha = id
app :: Value a -> Value a -> Value a
app (LamV f) x = f x
app (MuV f) x = MuV $ \y -> f x `app` y
app _ _ = appErr
eval :: Env a -> MuEnv a -> Expr -> Value a
eval env menv (Var v) = fromMaybe (varScopeErr v) $ lookup v env
eval env menv (Lam v e) = LamV $ \x -> eval ((v, x):env) menv e
eval env menv (Mu alpha beta e) = MuV $ \u ->
let menv' = (alpha, (`app` u)):menv
wrap = fromMaybe (muVarScopeErr beta) $ lookup beta menv'
in wrap (eval env menv' e)
eval env menv (App f e) = eval env menv f `app` eval env menv e
example 0 = App (App t (Var "v")) (Var "w")
where
t = Lam "x" $ Lam "y" $ Mu "delta" "phi" $ App (Var "x") (Var "y")
example n = App (example (n-1)) (Var ("z_" ++ show n))
I want to parse a String that depicts a propositional formula and then find all models of the propositional formula with a SAT solver.
Now I can parse a propositional formula with the hatt package; see the testParse function below.
I can also run a SAT solver call with the SBV library; see the testParse function below.
Question:
How do I, at runtime, generate a value of type Predicate like myPredicate within the SBV library that represents the propositional formula I just parsed from a String? I only know how to manually type the forSome_ $ \x y z -> ... expression, but not how to write a converter function from an Expr value to a value of type Predicate.
-- cabal install sbv hatt
import Data.Logic.Propositional
import Data.SBV
-- Random test formula:
-- (x or ~z) and (y or ~z)
-- graphical depiction, see: https://www.wolframalpha.com/input/?i=%28x+or+~z%29+and+%28y+or+~z%29
testParse = parseExpr "test source" "((X | ~Z) & (Y | ~Z))"
myPredicate :: Predicate
myPredicate = forSome_ $ \x y z -> ((x :: SBool) ||| (bnot z)) &&& (y ||| (bnot z))
testSat = do
x <- allSat $ myPredicate
putStrLn $ show x
main = do
putStrLn $ show $ testParse
testSat
{-
Need a function that dynamically creates a Predicate
(as I did with the function (like "\x y z -> ..") for an arbitrary expression of type "Expr" that is parsed from String.
-}
Information that might be helpful:
Here is the link to the BitVectors.Data:
http://hackage.haskell.org/package/sbv-3.0/docs/src/Data-SBV-BitVectors-Data.html
Here is example code form Examples.Puzzles.PowerSet:
import Data.SBV
genPowerSet :: [SBool] -> SBool
genPowerSet = bAll isBool
where isBool x = x .== true ||| x .== false
powerSet :: [Word8] -> IO ()
powerSet xs = do putStrLn $ "Finding all subsets of " ++ show xs
res <- allSat $ genPowerSet `fmap` mkExistVars n
Here is the Expr data type (from hatt library):
data Expr = Variable Var
| Negation Expr
| Conjunction Expr Expr
| Disjunction Expr Expr
| Conditional Expr Expr
| Biconditional Expr Expr
deriving Eq
Working With SBV
Working with SBV requires that you follow the types and realize the Predicate is just a Symbolic SBool. After that step it is important that you investigate and discover Symbolic is a monad - yay, a monad!
Now that you you know you have a monad then anything in the haddock that is Symbolic should be trivial to combine to build any SAT you desire. For your problem you just need a simple interpreter over your AST that builds a Predicate.
Code Walk-Through
The code is all included in one continuous form below but I will step through the fun parts. The entry point is solveExpr which takes expressions and produces a SAT result:
solveExpr :: Expr -> IO AllSatResult
solveExpr e0 = allSat prd
The application of SBV's allSat to the predicate is sort of obvious. To build that predicate we need to declare an existential SBool for every variable in our expression. For now lets assume we have vs :: [String] where each string corresponds to one of the Var from the expression.
prd :: Predicate
prd = do
syms <- mapM exists vs
let env = M.fromList (zip vs syms)
interpret env e0
Notice how programming language fundamentals is sneaking in here. We now need an environment that maps the expressions variable names to the symbolic booleans used by SBV.
Next we interpret the expression to produce our Predicate. The interpret function uses the environment and just applies the SBV function that matches the intent of each constructor from hatt's Expr type.
interpret :: Env -> Expr -> Predicate
interpret env expr = do
let interp = interpret env
case expr of
Variable v -> return (envLookup v env)
Negation e -> bnot `fmap` interp e
Conjunction e1 e2 ->
do r1 <- interp e1
r2 <- interp e2
return (r1 &&& r2)
Disjunction e1 e2 ->
do r1 <- interp e1
r2 <- interp e2
return (r1 ||| r2)
Conditional e1 e2 -> error "And so on"
Biconditional e1 e2 -> error "And so on"
And that is it! The rest is just boiler-plate.
Complete Code
import Data.Logic.Propositional hiding (interpret)
import Data.SBV
import Text.Parsec.Error (ParseError)
import qualified Data.Map as M
import qualified Data.Set as Set
import Data.Foldable (foldMap)
import Control.Monad ((<=<))
testParse :: Either ParseError Expr
testParse = parseExpr "test source" "((X | ~Z) & (Y | ~Z))"
type Env = M.Map String SBool
envLookup :: Var -> Env -> SBool
envLookup (Var v) e = maybe (error $ "Var not found: " ++ show v) id
(M.lookup [v] e)
solveExpr :: Expr -> IO AllSatResult
solveExpr e0 = allSat go
where
vs :: [String]
vs = map (\(Var c) -> [c]) (variables e0)
go :: Predicate
go = do
syms <- mapM exists vs
let env = M.fromList (zip vs syms)
interpret env e0
interpret :: Env -> Expr -> Predicate
interpret env expr = do
let interp = interpret env
case expr of
Variable v -> return (envLookup v env)
Negation e -> bnot `fmap` interp e
Conjunction e1 e2 ->
do r1 <- interp e1
r2 <- interp e2
return (r1 &&& r2)
Disjunction e1 e2 ->
do r1 <- interp e1
r2 <- interp e2
return (r1 ||| r2)
Conditional e1 e2 -> error "And so on"
Biconditional e1 e2 -> error "And so on"
main :: IO ()
main = do
let expr = testParse
putStrLn $ "Solving expr: " ++ show expr
either (error . show) (print <=< solveExpr) expr
forSome_ is a member of the Provable class, so it seems it would suffice to define the instance Provable Expr. Almost all functions in SVB use Provable so this would allow you to use all of those natively Expr. First, we convert an Expr to a function which looks up variable values in a Vector. You could also use Data.Map.Map or something like that, but the environment is not changed once created and Vector gives constant time lookup:
import Data.Logic.Propositional
import Data.SBV.Bridge.CVC4
import qualified Data.Vector as V
import Control.Monad
toFunc :: Boolean a => Expr -> V.Vector a -> a
toFunc (Variable (Var x)) = \env -> env V.! (fromEnum x)
toFunc (Negation x) = \env -> bnot (toFunc x env)
toFunc (Conjunction a b) = \env -> toFunc a env &&& toFunc b env
toFunc (Disjunction a b) = \env -> toFunc a env ||| toFunc b env
toFunc (Conditional a b) = \env -> toFunc a env ==> toFunc b env
toFunc (Biconditional a b) = \env -> toFunc a env <=> toFunc b env
Provable essentially defines two functions: forAll_, forAll, forSome_, forSome. We have to generate all possible maps of variables to values and apply the function to the maps. Choosing how exactly to handle the results will be done by the Symbolic monad:
forAllExp_ :: Expr -> Symbolic SBool
forAllExp_ e = (m0 >>= f . V.accum (const id) (V.replicate (fromEnum maxV + 1) false)
where f = return . toFunc e
maxV = maximum $ map (\(Var x) -> x) (variables e)
m0 = mapM fresh (variables e)
Where fresh is a function which "quantifies" the given variable by associating it with all possible values.
fresh :: Var -> Symbolic (Int, SBool)
fresh (Var var) = forall >>= \a -> return (fromEnum var, a)
If you define one of these functions for each of the four functions you will have quite a lot of very repetitive code. So you can generalize the above as follows:
quantExp :: (String -> Symbolic SBool) -> Symbolic SBool -> [String] -> Expr -> Symbolic SBool
quantExp q q_ s e = m0 >>= f . V.accum (const id) (V.replicate (fromEnum maxV + 1) false)
where f = return . toFunc e
maxV = maximum $ map (\(Var x) -> x) (variables e)
(v0, v1) = splitAt (length s) (variables e)
m0 = zipWithM fresh (map q s) v0 >>= \r0 -> mapM (fresh q_) v1 >>= \r1 -> return (r0++r1)
fresh :: Symbolic SBool -> Var -> Symbolic (Int, SBool)
fresh q (Var var) = q >>= \a -> return (fromEnum var, a)
If it is confusing exactly what is happening, the Provable instance may suffice to explain:
instance Provable Expr where
forAll_ = quantExp forall forall_ []
forAll = quantExp forall forall_
forSome_ = quantExp exists exists_ []
forSome = quantExp exists exists_
Then your test case:
myPredicate :: Predicate
myPredicate = forSome_ $ \x y z -> ((x :: SBool) ||| (bnot z)) &&& (y ||| (bnot z))
myPredicate' :: Predicate
myPredicate' = forSome_ $ let Right a = parseExpr "test source" "((X | ~Z) & (Y | ~Z))" in a
testSat = allSat myPredicate >>= print
testSat' = allSat myPredicate >>= print
---- update 2 ----
At last, he told me that is Exists…
thank you all.
---- update ----
Okay, we call it Forsome
ex3: forsome x0::[False,True]. forsome x1::[0,1,2]. (x0 || (0 < x1))
(whom told me "what is forall" added):
the constructor says "forall x in blah" but it really means "for some x in blah".
the formula is satisfied for some assignment of variables so it is satisfiable.
How can I do it?
Thanks
---- original ----
Suppose we have a formula ex3
ex3: forall x0::[False,True]. forall x1::[0,1,2]. (x0 || (0 < x1)).
At first I think ex3 is False, cause when x0 = False and x1 = 0 the formula is (False || (0 < 0)) so ex3 is absolutely false. But I be told that ex3 is True,
"satisfiable ex3 is true because there is at least one combination from sets x0 and x1 which returns true. So as long as there is 1 valid solution in Forall, it is true."
Assume that is correct…
I think it need to check groups of combination with same level but I am not figure out how to do it. To determine 'Are them same group` seems difficult.
Here is my codes:
File: Formula.hs
{-# LANGUAGE GADTs #-}
module Formula where
-- Datatype of formulas
-- --------------------
data Formula ts where
Body :: Term Bool -> Formula ()
Forall :: Show a
=> [a] -> (Term a -> Formula as) -> Formula (a, as)
data Term t where
Con :: t -> Term t
And :: Term Bool -> Term Bool -> Term Bool
Or :: Term Bool -> Term Bool -> Term Bool
Smaller :: Term Int -> Term Int -> Term Bool
Plus :: Term Int -> Term Int -> Term Int
Name :: String -> Term t -- to facilitate pretty printing
-- Pretty printing formulas
-- ------------------------
instance Show t => Show (Term t) where
show (Con v) = show v
show (And p q) = "(" ++ show p ++ " && " ++ show q ++ ")"
show (Or p q) = "(" ++ show p ++ " || " ++ show q ++ ")"
show (Smaller n m) = "(" ++ show n ++ " < " ++ show m ++ ")"
show (Plus n m) = "(" ++ show n ++ " + " ++ show m ++ ")"
show (Name name) = name
instance Show (Formula ts) where
show = show' ['x' : show i | i <- [0..]]
where
show' :: [String] -> Formula ts' -> String
show' ns (Body body) = show body
show' (n:ns) (Forall vs p) = "forall " ++ n ++ "::" ++ show vs ++ ". " ++ show' ns (p (Name n))
-- Example formulas
-- ----------------
ex1 :: Formula ()
ex1 = Body (Con True)
ex2 :: Formula (Int, ())
ex2 = Forall [1..10] $ \n ->
Body $ n `Smaller` (n `Plus` Con 1)
ex3 :: Formula (Bool, (Int, ()))
ex3 = Forall [False, True] $ \p ->
Forall [0..2] $ \n ->
Body $ p `Or` (Con 0 `Smaller` n)
wrongFormula :: Formula (Int, ())
wrongFormula = Forall [0..4] $ \n ->
Body $ n `Smaller` (Con 0)
File: Solver.hs
{-# LANGUAGE GADTs #-}
module Solver where
import Formula
-- Evaluating terms
-- ----------------
eval :: Term t -> t
eval (Con v) = v
eval (And p q) = eval p && eval q
eval (Or p q) = eval p || eval q
eval (Smaller n m) = eval n < eval m
eval (Plus n m) = eval n + eval m
eval (Name _) = error "eval: Name"
-- Checking formulas
-- -----------------
satisfiable :: Formula ts -> Bool
satisfiable (Body body) = eval body
-- FIXME wrong implement
--satisfiable (Forall xs f) = helper f xs
-- where helper :: (Term a -> Formula t) -> [a] -> Bool
-- helper fn (a:as) = (satisfiable $ (fn . Con) a) && (helper fn as)
-- helper _ [] = True
Any suggestion will be appreciated.
I agree with Daniel that this describes Exists, not Forall, but if you want to interpret it that way, you just have to change && to || and True to False.
Or, even better, using the Prelude functions
all :: (a -> Bool) -> [a] -> Bool -- is predicate true for all elements?
any :: (a -> Bool) -> [a] -> Bool -- is predicate true for any element?
you can write your existing implementation as
satisfiable (Forall xs f) = all (satisfiable . f . Con) xs
so to change it, you just change the all to any.
I am trying to implement a unify function with an algorithm that is specified as
unify α α = idSubst
unify α β = update (α, β) idSubst
unify α (τ1 ⊗ τ2) =
if α ∈ vars(τ1 ⊗ τ2) then
error ”Occurs check failure”
else
update (α, τ1 ⊗ τ2) idSubst
unify (τ1 ⊗ τ2) α = unify α (τ1 ⊗ τ2)
unify (τ1 ⊗1 τ2) (τ3 ⊗2 τ4) = if ⊗1 == ⊗2 then
(subst s2) . s1
else
error ”not unifiable.”
where s1 = unify τ1 τ3
s2 = unify (subst s1 τ2) (subst s1 τ4)
with ⊗ being one of the type constructors {→, ×}.
However I do not understand how to implement this in haskell. How would I go about this?
import Data.List
import Data.Char
data Term = Var String | Abs (String,Term) | Ap Term Term | Pair Term Term | Fst Term | Snd Term
deriving (Eq,Show)
data Op = Arrow | Product deriving (Eq)
data Type = TVar String | BinType Op Type Type
deriving (Eq)
instance Show Type where
show (TVar x) = x
show (BinType Arrow t1 t2) = "(" ++ show t1 ++ " -> " ++ show t2 ++ ")"
show (BinType Product t1 t2) = "(" ++ show t1 ++ " X " ++ show t2 ++ ")"
type Substitution = String -> Type
idSubst :: Substitution
idSubst x = TVar x
update :: (String, Type) -> Substitution -> Substitution
update (x,y) f = (\z -> if z == x then y else f z)
-- vars collects all the variables occuring in a type expression
vars :: Type -> [String]
vars ty = nub (vars' ty)
where vars' (TVar x) = [x]
vars' (BinType op t1 t2) = vars' t1 ++ vars' t2
subst :: Substitution -> Type -> Type
subst s (TVar x) = s x
subst s (BinType op t1 t2) = BinType op (subst s t1) (subst s t2)
unify :: Type -> Type -> Substitution
unify (TVar x) (TVar y) = update (x, TVar y) idSubst
unify :: Type -> Type -> Substitution
unify (TVar x) (TVar y) = update (x, TVar y) idSubst
This is a great start!
Now you just need to handle the other cases:
Here's how you'd represent the first one:
unify (TVar x) (TVar y) | x == y = idSubst
You can do the rest similarly using pattern matching to decompose your Type into the appropriate constructors and guards to handle specific cases.
Haskell has an error :: String -> a function that works the same as in your pseudo-code above, and the if/then/else syntax is the same, so you're almost there!