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!
Related
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.
I'm reading the lectures from the CIS194 course (version fall 2014) and I
wanted to have some comments on my solution to the Exercise 7 of the
Homework 5.
Here is the question:
Exercise 7 (Optional) The distribute and squashMulId functions are
quite similar, in that they traverse over the whole expression to make
changes to specific nodes. Generalize this notion, so that the two
functions can concentrate on just the bit that they need to transform.
(You can see the whole homework here: http://www.seas.upenn.edu/~cis194/fall14/hw/05-type-classes.pdf)
Here is my squashMulId function from Exercise 6:
squashMulId :: (Eq a, Ring a) => RingExpr a -> RingExpr a
squashMulId AddId = AddId
squashMulId MulId = MulId
squashMulId (Lit n) = Lit n
squashMulId (AddInv x) = AddInv (squashMulId x)
squashMulId (Add x y) = Add (squashMulId x) (squashMulId y)
squashMulId (Mul x (Lit y))
| y == mulId = squashMulId x
squashMulId (Mul (Lit x) y)
| x == mulId = squashMulId y
squashMulId (Mul x y) = Mul (squashMulId x) (squashMulId y)
And here is my solution to Exercise 7:
distribute :: RingExpr a -> RingExpr a
distribute = transform distribute'
where distribute' (Mul x (Add y z)) = Just $ Add (Mul x y) (Mul x z)
distribute' (Mul (Add x y) z) = Just $ Add (Mul x z) (Mul y z)
distribute' _ = Nothing
squashMulId :: (Eq a, Ring a) => RingExpr a -> RingExpr a
squashMulId = transform simplifyMul
where simplifyMul (Mul x (Lit y))
| y == mulId = Just $ squashMulId x
simplifyMul (Mul (Lit x) y)
| x == mulId = Just $ squashMulId y
simplifyMul _ = Nothing
transform :: (RingExpr a -> Maybe (RingExpr a)) -> RingExpr a -> RingExpr a
transform f e
| Just expr <- f e = expr
transform _ AddId = AddId
transform _ MulId = MulId
transform _ e#(Lit n) = e
transform f (AddInv x) = AddInv (transform f x)
transform f (Add x y) = Add (transform f x) (transform f y)
transform f (Mul x y) = Mul (transform f x) (transform f y)
Is there a better way of doing such generalization?
Your transform function is a very good start at handling general transformations of ASTs. I'm going to show you something closely related that's a little bit more general.
The uniplate library defines the following class for describing simple abstract syntax trees. An instance of the class needs only provide a definition for uniplate which should perform a step of transformation, possibly with side-effects, to the immediate decedents of the node.
import Control.Applicative
import Control.Monad.Identity
class Uniplate a where
uniplate :: Applicative m => a -> (a -> m a) -> m a
descend :: (a -> a) -> a -> a
descend f x = runIdentity $ descendM (pure . f) x
descendM :: Applicative m => (a -> m a) -> a -> m a
descendM = flip uniplate
A postorder transformation of the entire expression is defined for any type with a Uniplate instance.
transform :: Uniplate a => (a -> a) -> a -> a
transform f = f . descend (transform f)
My guess for the definitions of RingExpr and Ring (the link to the homework exercise is broken) are
data RingExpr a
= AddId
| MulId
| Lit a
| AddInv (RingExpr a)
| Add (RingExpr a) (RingExpr a)
| Mul (RingExpr a) (RingExpr a)
deriving Show
class Ring a where
addId :: a
mulId :: a
addInv :: a -> a
add :: a -> a -> a
mul :: a -> a -> a
We can define uniplate for any RingExpr a. For the three expressions that have subexpressions, AddInv, Add, and Mul, we perform the transformation p on each subexpression, then put the expression back together again in the Applicative using <$> (an infix version of fmap), and <*>. For the remaining expressions that have no sub expressions, we just package them back up in the Applicative using pure.
instance Uniplate (RingExpr a) where
uniplate e p = case e of
AddInv x -> AddInv <$> p x
Add x y -> Add <$> p x <*> p y
Mul x y -> Mul <$> p x <*> p y
_ -> pure e
The transform function we get from the Uniplate instance for RingExpr a is exactly the same as yours, except the Maybe return type wasn't necessary. A function that didn't want to change an expression could have simply returned the expression unchanged.
Here's my swing at writing squashMulId. I've split replacing the literals out into a separate function to make things look cleaner.
replaceIds :: (Eq a, Ring a) => RingExpr a -> RingExpr a
replaceIds (Lit n) | n == addId = AddId
replaceIds (Lit n) | n == mulId = MulId
replaceIds e = e
simplifyMul :: RingExpr a -> RingExpr a
simplifyMul (Mul x MulId) = x
simplifyMul (Mul MulId x ) = x
simplifyMul e = e
squashMulId :: (Eq a, Ring a) => RingExpr a -> RingExpr a
squashMulId = transform (simplifyMul . replaceIds)
This works for a simple example
> squashMulId . Mul (Lit True) . Add (Lit False) $ Lit True
Add AddId MulId
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
Suppose there are some data types to express lambda and combinatorial terms:
data Lam α = Var α -- v
| Abs α (Lam α) -- λv . e1
| App (Lam α) (Lam α) -- e1 e2
deriving (Eq, Show)
infixl 0 :#
data SKI α = V α -- x
| SKI α :# SKI α -- e1 e2
| I -- I
| K -- K
| S -- S
deriving (Eq, Show)
There is also a function to get a list of lambda term's free variables:
fv ∷ Eq α ⇒ Lam α → [α]
fv (Var v) = [v]
fv (Abs x e) = filter (/= x) $ fv e
fv (App e1 e2) = fv e1 ++ fv e2
To convert lambda term to combinatorial term abstract elimination rules could be usefull:
convert ∷ Eq α ⇒ Lam α → SKI α
1) T[x] => x
convert (Var x) = V x
2) T[(E₁ E₂)] => (T[E₁] T[E₂])
convert (App e1 e2) = (convert e1) :# (convert e2)
3) T[λx.E] => (K T[E]) (if x does not occur free in E)
convert (Abs x e) | x `notElem` fv e = K :# (convert e)
4) T[λx.x] => I
convert (Abs x (Var y)) = if x == y then I else K :# V y
5) T[λx.λy.E] => T[λx.T[λy.E]] (if x occurs free in E)
convert (Abs x (Abs y e)) | x `elem` fv e = convert (Abs x (convert (Abs y e)))
6) T[λx.(E₁ E₂)] => (S T[λx.E₁] T[λx.E₂])
convert (Abs x (App y z)) = S :# (convert (Abs x y)) :# (convert (Abs x z))
convert _ = error ":["
This definition is not valid because of 5):
Couldn't match expected type `Lam α' with actual type `SKI α'
In the return type of a call of `convert'
In the second argument of `Abs', namely `(convert (Abs y e))'
In the first argument of `convert', namely
`(Abs x (convert (Abs y e)))'
So, what I have now is:
> convert $ Abs "x" $ Abs "y" $ App (Var "y") (Var "x")
*** Exception: :[
What I want is (hope I calculate it right):
> convert $ Abs "x" $ Abs "y" $ App (Var "y") (Var "x")
S :# (S (KS) (S (KK) I)) (S (KK) I)
Question:
If lambda term and combinatorial term have a different types of expression, how 5) could be formulated right?
Let's consider the equation T[λx.λy.E] => T[λx.T[λy.E]].
We know the result of T[λy.E] is an SKI expression. Since it has been produced by one of the cases 3, 4 or 6, it is either I or an application (:#).
Thus the outer T in T[λx.T[λy.E]] must be one of the cases 3 or 6. You can perform this case analysis in the code. I'm sorry but I don't have the time to write it out.
Here it's better to have a common data type for combinators and lambda expressions. Notice that your types already have significant overlap (Var, App), and it doesn't hurt to have combinators in lambda expressions.
The only possibility we want to eliminate is having lambda abstractions in combinator terms. We can forbid them using indexed types.
In the following code the type of a term is parameterised by the number of nested lambda abstractions in that term. The convert function returns Term Z a, where Z means zero, so there are no lambda abstractions in the returned term.
For more information about singleton types (which are used a bit here), see the paper Dependently Typed Programming with Singletons.
{-# LANGUAGE DataKinds, KindSignatures, TypeFamilies, GADTs, TypeOperators,
ScopedTypeVariables, MultiParamTypeClasses, FlexibleInstances #-}
data Nat = Z | Inc Nat
data SNat :: Nat -> * where
SZ :: SNat Z
SInc :: NatSingleton n => SNat n -> SNat (Inc n)
class NatSingleton (a :: Nat) where
sing :: SNat a
instance NatSingleton Z where sing = SZ
instance NatSingleton a => NatSingleton (Inc a) where sing = SInc sing
type family Max (a :: Nat) (b :: Nat) :: Nat
type instance Max Z a = a
type instance Max a Z = a
type instance Max (Inc a) (Inc b) = Inc (Max a b)
data Term (l :: Nat) a where
Var :: a -> Term Z a
Abs :: NatSingleton l => a -> Term l a -> Term (Inc l) a
App :: (NatSingleton l1, NatSingleton l2)
=> Term l1 a -> Term l2 a -> Term (Max l1 l2) a
I :: Term Z a
K :: Term Z a
S :: Term Z a
fv :: Eq a => Term l a -> [a]
fv (Var v) = [v]
fv (Abs x e) = filter (/= x) $ fv e
fv (App e1 e2) = fv e1 ++ fv e2
fv _ = []
eliminateLambda :: (Eq a, NatSingleton l) => Term (Inc l) a -> Term l a
eliminateLambda t =
case t of
Abs x t ->
case t of
Var y
| y == x -> I
| otherwise -> App K (Var y)
Abs {} -> Abs x $ eliminateLambda t
App a b -> S `App` (eliminateLambda $ Abs x a)
`App` (eliminateLambda $ Abs x b)
App a b -> eliminateLambdaApp a b
eliminateLambdaApp
:: forall a l1 l2 l .
(Eq a, Max l1 l2 ~ Inc l,
NatSingleton l1,
NatSingleton l2)
=> Term l1 a -> Term l2 a -> Term l a
eliminateLambdaApp a b =
case (sing :: SNat l1, sing :: SNat l2) of
(SInc _, SZ ) -> App (eliminateLambda a) b
(SZ , SInc _) -> App a (eliminateLambda b)
(SInc _, SInc _) -> App (eliminateLambda a) (eliminateLambda b)
convert :: forall a l . Eq a => NatSingleton l => Term l a -> Term Z a
convert t =
case sing :: SNat l of
SZ -> t
SInc _ -> convert $ eliminateLambda t
The key insight is that S, K and I are just constant Lam terms, in the same way that 1, 2 and 3 are constant Ints. It would be pretty easy to make rule 5 type-check by making an inverse to the 'convert' function:
nvert :: SKI a -> Lam a
nvert S = Abs "x" (Abs "y" (Abs "z" (App (App (Var "x") (Var "z")) (App (Var "y") (Var "z")))))
nvert K = Abs "x" (Abs "y" (Var "x"))
nvert I = Abs "x" (Var "x")
nvert (V x) = Var x
nvert (x :# y) = App (nvert x) (nvert y)
Now we can use 'nvert' to make rule 5 type-check:
convert (Abs x (Abs y e)) | x `elem` fv e = convert (Abs x (nvert (convert (Abs y e))))
We can see that the left and the right are identical (we'll ignore the guard), except that 'Abs y e' on the left is replaced by 'nvert (convert (Abs y e))' on the right. Since 'convert' and 'nvert' are each others' inverse, we can always replace any Lam 'x' with 'nvert (convert x)' and likewise we can always replace any SKI 'x' with 'convert (nvert x)', so this is a valid equation.
Unfortunately, while it's a valid equation it's not a useful function definition because it won't cause the computation to progress: we'll just convert 'Abs y e' back and forth forever!
To break this loop we can replace the call to 'nvert' with a 'reminder' that we should do it later. We do this by adding a new constructor to Lam:
data Lam a = Var a -- v
| Abs a (Lam a) -- \v . e1
| App (Lam a) (Lam a) -- e1 e2
| Com (SKI a) -- Reminder to COMe back later and nvert
deriving (Eq, Show)
Now rule 5 uses this reminder instead of 'nvert':
convert (Abs x (Abs y e)) | x `elem` fv e = convert (Abs x (Com (convert (Abs y e))))
Now we need to make good our promise to come back, by making a separate rule to replace reminders with actual calls to 'nvert', like this:
convert (Com c) = convert (nvert c)
Now we can finally break the loop: we know that 'convert (nvert c)' is always identical to 'c', so we can replace the above line with this:
convert (Com c) = c
Notice that our final definition of 'convert' doesn't actually use 'nvert' at all! It's still a handy function though, since other functions involving Lam can use it to handle the new 'Com' case.
You've probably noticed that I've actually named this constructor 'Com' because it's just a wrapped-up COMbinator, but I thought it would be more informative to take a slightly longer route than just saying "wrap up your SKIs in Lams" :)
If you're wondering why I called that function "nvert", see http://unapologetic.wordpress.com/2007/05/31/duality-terminology/ :)
Warbo is right, combinators are constant lambda terms, consequently the conversion function is
T[ ]:L -> C with L the set of lambda terms and C that of combinatory terms and with C ⊂ L .
So there is no typing problem for the rule T[λx.λy.E] => T[λx.T[λy.E]]
Here an implementation in Scala.
---- 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.