Check whether formula is correct in haskell - haskell

---- 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.

Related

Couldn't match type ‘Either String’ with ‘[]’

I have this main method:
main :: IO ()
main = do
x <- getArgs
case x of
[] -> putStrLn "Empty"
[x] -> putStrLn (split x >>= (\(a,b) -> a ++ " " ++ b))
_ -> putStrLn "More than one argument"
where split function is defined as:
split :: String -> Either String (String, String)
What am I doing here wrong? What I want to do here is just to print my tuple returned from split function
putStrLn (split x >>= (\(a,b) -> a ++ " " ++ b))
The monadic bind operator >>= has signature
(>>=) :: Monad m => m a -> (a -> m b) -> m b
Or, in your specific case,
(>>=) :: Either e a -> (a -> Either e b) -> Either e b
So we use >>= when we have an Either and want to pass the thing inside of it to a function which itself returns an Either. But your function is \(a,b) -> a ++ " " ++ b), which doesn't return an Either. What you want to do is take an Either and apply the function to the inside, leaving the Either part alone. That's a use of fmap from the Functor typeclass.
fmap :: Functor f => (a -> b) -> f a -> f b
-- Specifically
fmap :: (a -> b) -> Either e a -> Either e b
So you want
fmap (\(a,b) -> a ++ " " ++ b) $ split x
This will return a Either String String. putStrLn is equipped to print strings. If we want to print the Either, then you need to use print.
print (fmap (\(a,b) -> a ++ " " ++ b) $ split x)
On the other hand, we could pattern match on the result and do something different in the Left case.
case fmap (\(a,b) -> a ++ " " ++ b) $ split x of
Left e -> undefined -- Error case
Right s -> putStrLn s

Reference data from function

I have those info on my haskell code:
data Symtable a = General a | Stack a
class Evaluable e where
eval :: (Num a, Ord a) => (Ident -> Maybe a) -> (e a) -> (Either String a)
typeCheck :: (Ident -> String) -> (e a) -> Bool
instance (Num a, Ord a) => Evaluable (NExpr a) where
eval f f2 = Left ("Undefined variable: ") --to make the code compilable
typeCheck f f2 = True --to make the code compilable
The thing is, eval function returns the evaluation of a numeric expression (for example 3 + 5, or x + 3), therefore I have to check the value of X on the symtable data but I haven't got it referenced on this function (I cannot edit the function header). How can I do it?
ident = string and Nexpr:
data NExpr n = Const n |
Var Ident |
Plus (NExpr n) (NExpr n) |
Minus (NExpr n) (NExpr n) |
Times (NExpr n) (NExpr n)
The first arugment to eval is a function that will look up the value of a name found in an expression. You ignore it when evaluating a Const value, use it when evaluating a Var value, and just pass it along to the recursive calls for the other cases.
instance (Num a, Ord a) => Evaluable (NExpr a) where
eval _ (Const n) = Right n
eval lookup (Var x) = case lookup x of
Nothing -> Left ("Undefined variable: " ++ x)
Just y -> Right y
eval lookup (Plus left right) = (+) <$> eval lookup left <*> eval lookup right
-- etc

SAT solving with haskell SBV library: how to generate a predicate from a parsed string?

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

Haskell: how to define instance Show Set for type Set = Int -> Bool

I am doing the exercise's to Martin Odersky's "Functional Programming Principles in Scala" coursera course in both Scala and Haskell.
For the "sets as functions" exercises I have defined a "toString" function:
import Data.List (intercalate)
type Set = Int -> Bool
contains :: Set -> Int -> Bool
contains s elem = s elem
bound = 1000
toString :: Set -> String
toString s =
let xs = [(show x) | x <- [(-bound) .. bound], contains s x]
in "{" ++ (intercalate "," xs) ++ "}"
-- toString (\x -> x > -3 && x < 10)
-- => "{-2,-1,0,1,2,3,4,5,6,7,8,9}"
It would be great to be able to define:
instance Show Set where
show Set = ...
but the definition needs to reference and call the function thqt represents the Set (i.e., see the 'toString' function).
Is there any Haskell magic that can be used to define 'Show Set' ?
UPDATE based on feedback:
After trying the two solutions suggested and reading
Difference between `data` and `newtype` in Haskell
it seems that using type or newtype gives me the same "performance" (i.e., read above link) but that 'newtype' give me stronger type-safety, e.g., : I can pass ANY Int -> Bool function to functions that take type Set = Int -> Bool but MUST pass a Set' when defined as newtype Set' = Set' (Int -> Bool).
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
import Data.List (intercalate)
bound = 1000
-- ALTERNATE #1
type Set = Int -> Bool
contains :: Set -> Int -> Bool
contains s elem = s elem
intersect :: Set -> Set -> Set
intersect s t = \x -> s x && t x
toString :: Set -> String
toString s =
let xs = [(show x) | x <- [(-bound) .. bound], contains s x]
in "{" ++ (intercalate "," xs) ++ "}"
instance Show Set where show = toString
-- ALTERNATE #2
newtype Set' = Set' (Int -> Bool)
contains' :: Set' -> Int -> Bool
contains' (Set' s) elem = s elem
intersect' :: Set' -> Set' -> Set'
intersect' (Set' s) (Set' t) = Set' (\x -> s x && t x)
instance Show Set' where
show (Set' s) =
let xs = [(show x) | x <- [(-bound) .. bound], s x]
in "{" ++ (intercalate "," xs) ++ "}"
anyIntBoolFun1 = \x -> -10 < x
anyIntBoolFun2 = \x -> x < 0
setIntBoolFun1 = Set' anyIntBoolFun1
setIntBoolFun2 = Set' anyIntBoolFun2
main = do
putStrLn $ show $ intersect anyIntBoolFun1 anyIntBoolFun2
putStrLn $ show $ intersect' setIntBoolFun1 setIntBoolFun2
-- *Main> main
-- {-9,-8,-7,-6,-5,-4,-3,-2,-1}
-- {-9,-8,-7,-6,-5,-4,-3,-2,-1}
Yes, it's as easy as
instance Show Set where show = toString
though you will need to turn on TypeSynonymInstances and FlexibleInstances. The complete file would look like this:
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
import Data.List (intercalate)
type Set = Int -> Bool
contains :: Set -> Int -> Bool
contains s elem = s elem
bound = 1000
toString :: Set -> String
toString s =
let xs = [(show x) | x <- [(-bound) .. bound], contains s x]
in "{" ++ (intercalate "," xs) ++ "}"
instance Show Set where show = toString
In ghci:
*Main> (\x -> x > -3 && x < 10) :: Set
{-2,-1,0,1,2,3,4,5,6,7,8,9}
However, this has some caveats: namely, polymorphic functions won't match the given instance. (The type ascription :: Set in the ghci sample above is required, for example.)
You need to make Set a newtype instead of a type synonym, like this:
newtype Set = Set { unSet :: Int -> Bool }
Then you can make it an instance of any class, like Show:
instance Show Set where
show (Set s) =
let xs = [(show x) | x <- [(-bound) .. bound], contains s x]
in "{" ++ (intercalate "," xs) ++ "}"

Printing an AST with variable names

I am trying to implement an EDSL in Haskell. I would like to pretty print the AST with the variable names that are bound (if I can't get the real names then some generated names would do).
This is how far I have got with a simple example:
import Control.Monad.State
data Free f a = Roll (f (Free f a))
| Pure a
instance Functor f => Monad (Free f) where
return = Pure
(Pure a) >>= f = f a
(Roll f) >>= g = Roll $ fmap (>>= g) f
data Expr a = I a
| Plus (Expr a) (Expr a)
deriving (Show)
data StackProgram a next = Pop (a -> next)
| Push a next
instance Functor (StackProgram a) where
fmap f (Pop k) = Pop (f.k)
fmap f (Push i x) = Push i (f x)
liftF :: Functor f => f a -> Free f a
liftF l = Roll $ fmap return l
push :: a -> Free (StackProgram a) ()
push i = liftF $ Push i ()
pop :: Free (StackProgram a) a
pop = liftF $ Pop id
prog3 :: Free (StackProgram (Expr Int)) (Expr Int)
prog3 = do
push (I 3)
push (I 4)
a <- pop
b <- pop
return (Plus a b)
showSP' :: (Show a, Show b) => Free (StackProgram a) b -> [a] -> State Int String
showSP' (Pure a) _ = return $ "return " ++ show a
showSP' (Roll (Pop f)) (a:stack) = do
i <- get
put (i+1)
rest <- showSP' (f a) stack
return $ "var" ++ show i ++ " <- pop " ++ show (a:stack) ++ "\n" ++ rest
showSP' (Roll (Push i n)) stack = do
rest <- showSP' n (i:stack)
return $ "push " ++ show i ++ " " ++ show stack ++ "\n" ++ rest
showSP :: (Show a, Show b) => Free (StackProgram a) b -> [a] -> String
showSP prg stk = fst $ runState (showSP' prg stk) 0
Running this gives:
*Main> putStrLn $ showSP prog3 []
push I 3 []
push I 4 [I 3]
var0 <- pop [I 4,I 3]
var1 <- pop [I 3]
return Plus (I 4) (I 3)
So what I want is to replace Plus (I 4) (I 3) with Plus var0 var1. I have thought about walking through the rest of the tree and replacing the bound variables with name-value tuples, but I am not 100% sure if/how that would work. I'd also prefer to keep the original variable names, but I can't think of an easy way of doing this. I would prefer to have a fairly light-weight syntax in haskell (kind of as above).
I would also appreciate pointers to material that teaches me how to best do these kinds of things. I have read a bit on free monads and GADTs, but I guess I am missing how to put it all together.
With the structure you have, you can't do this in "pure" Haskell code, because once your code is compiled, you can't distinguish (Plus a b) from (Plus (I 4) (I 3)) and keep "referential transparency" - the interchangeability of variables and their values.
However there are unsafe hacks - i.e. not guaranteed to work - that can let you do this kind of thing. They generally go under the name "observable sharing" and are based on getting access to the internals of how values are represented, using StableName. Essentially that gives you a pointer equality operation that allows you to distinguish between the reference to a and a new copy of the value (I 4).
One package that helps wrap up this functionality is data-reify.
The actual variable names used in your source will be irretrievably lost during compilation. In Paradise we use a preprocessor to translate foo <~ bar into foo <- withName "foo" $ bar before compilation, but it's hacky and it slows down builds quite a bit.
I figured this out based on #Gabriel Gonzales' linked answer. The basic idea is to introduce a new variable constructor in the Expr type and you assign these a unique id as you interpret the tree. That and cleaning up the code a bit gives:
import Control.Monad.Free
import Data.Map
newtype VInt = VInt Int
data Expr = IntL Int
| IntV VInt
| Plus Expr Expr
instance Show Expr where
show (IntL i) = show i
show (IntV (VInt i)) = "var" ++ show i
show (Plus e1 e2) = show e1 ++ " + " ++ show e2
data StackProgF next = Pop (VInt -> next)
| Push Expr next
instance Functor StackProgF where
fmap f (Pop k) = Pop (f.k)
fmap f (Push e x) = Push e (f x)
type StackProg = Free StackProgF
type Stack = [Expr]
push :: Expr -> StackProg ()
push e = liftF $ Push e ()
pop :: StackProg Expr
pop = liftF $ Pop IntV
prog3 :: StackProg Expr
prog3 = do
push (IntL 3)
push (IntL 4)
a <- pop
b <- pop
return (Plus a b)
showSP :: StackProg Expr -> String
showSP prg = go 0 prg []
where
go i (Pure a) _ = show a
go i (Free (Pop n)) (h:t) = "var" ++ show i ++ " <- pop " ++ show (h:t) ++ "\n" ++
go (i+1) (n (VInt i)) t
go i (Free (Pop _)) [] = "error: pop on empty stack\n"
go i (Free (Push e n)) stk = "push " ++ show e ++ ", " ++ show stk ++ "\n" ++ go i n (e:stk)
type Env = Map Int Expr
evalExpr :: Expr -> Env -> Int
evalExpr (IntL i) _ = i
evalExpr (IntV (VInt k)) env = evalExpr (env ! k) env
evalExpr (Plus e1 e2) env = evalExpr e1 env + evalExpr e2 env
evalSP :: StackProg Expr -> Int
evalSP prg = go 0 prg [] empty
where
go i (Free (Pop _)) [] env = error "pop on empty stack\n"
go i (Free (Pop n)) (h:t) env = go (i+1) (n (VInt i)) t (insert i h env)
go i (Free (Push e n)) stk env = go i n (e:stk) env
go i (Pure a) _stk env = evalExpr a env
Pretty printing and running:
*Main> putStrLn $ showSP prog3
push 3, []
push 4, [3]
var0 <- pop [4,3]
var1 <- pop [3]
var0 + var1
*Main> evalSP prog3
7

Resources