Create a gist now

Instantly share code, notes, and snippets.

-- file: QuickPiet.hs
-- An implementation of QuickPiet by Ben Lee
-- based on the Piet language by ???
-- I haven't tested this code, but if you'd like to, then the following will get you on your way:
-- $ ghc --make QuickPiet.hs
-- $ ./QuickPiet filename
-- where filename is some script file you want to run
-- Good Luck!
-- These are the stack operations which follow the actions available with the Piet programming languages with some
-- small changes to allow algorithms to be tested without the need of creating valid Piet images.
-- Original Piet information can be found at http://www.dangermouse.net/esoteric/piet.html
-- Just as in Piet, this language spec assumes a single "infinite" stack and a linear command execution order.
-- Blank lines should be ignored.
-- An implicit "end" command is present at the bottom of the document.
-- file: Piet.hs
-- An Interpreter for Ben's Piet Challenge
import Data.Char
import System
import System.IO
import Text.ParserCombinators.Parsec
type Stack = [Int]
data Interpreter = Interpreter [Command] [Command] String String Stack
| Finished [Command] [Command] String String Stack
data Command = Push Int
| Pop
| Duplicate
| Roll
| In
| Out
| Add
| Subtract
| Multiply
| Divide
| Mod
| Not
| Greater
| End
| Comment
| Label String
| Goto String String
deriving (Eq, Show)
-- push X
-- Pushes the value of X onto the stack. X should be a positive integer
push :: Int -> [Int] -> [Int]
push elt stack = elt:stack
-- pop
-- Pops the top value of the stack and discards
pop :: [Int] -> [Int]
pop (elt:stack) = stack
-- duplicate
-- Pushes a copy of the top value of the stack onto the stack
duplicate :: [Int] -> [Int]
duplicate (x:stack) = x:x:stack
-- roll
-- Pops the top two values, and "rolls" the remaining stack entries to a depth equal to the second value popped ...
-- By a number of rolls equal to the first value popped ...
-- A single roll to depth n is defined as burying the top value on the stack n deep ...
-- And bringing all values above it up by 1 place ...
-- A negative number of rolls rolls in the opposite direction
roll :: [Int] -> [Int]
roll (x:y:stack) = (roll' x top) ++ bot
where (top, bot) = splitAt y stack
roll' 0 lst = lst
roll' n (elt:lst) = roll' (n - 1) (lst ++ [elt])
-- in
-- Read a single value from STDIN and push it onto the stack; characters are read as their ASCII value
inop :: String -> [Int] -> (String, [Int])
inop bs stack = (cs, (c:stack))
where c = ord (head bs)
cs = tail bs
-- out
-- Pop the top value from the stack and output it to STDOUT in it's ASCII character value
outop :: String -> [Int] -> (String, [Int])
outop bs (x:stack) = ((b:bs), stack)
where b = chr x
-- add
-- Pops the top two values, adds them, and pushes the result
add :: [Int] -> [Int]
add (x:y:stack) = (x + y):stack
-- subtract
-- Pops the top two values, subtracts the top value from the second top value, and pushes the result
subtractop :: [Int] -> [Int]
subtractop (x:y:stack) = (y - x):stack
-- multiply
-- Pops the top two values, multiplies them, and pushes the result
multiply :: [Int] -> [Int]
multiply (x:y:stack) = (x * y):stack
-- divide
-- Pops the top two values, integer divides the second top value by the top value, and pushes the result
divide :: [Int] -> [Int]
divide (x:y:stack) = (y `div` x):stack
-- mod
-- Pops the top two values, calculates the second top value modulo the top value, and pushes the result
modop :: [Int] -> [Int]
modop (x:y:stack) = (y `mod` x):stack
-- not
-- Replaces the top value of the stack with 0 if it is non-zero, and 1 if it is zero
notop :: [Int] -> [Int]
notop (0:stack) = 1:stack
notop (_:stack) = 0:stack
-- greater
-- Pops the top two values, pushes 1 on to the stack if the second top value is greater than the top value, 0 otherwise
greater :: [Int] -> [Int]
greater (x:y:stack)
| y > x = 1:stack
| otherwise = 0:stack
-- end
-- Stop program execution, values left on the stack are discarded
end :: [Int] -> [Int]
end _ = []
-- Comments start with #
-- :label
-- Line label must begin with a ":" character and at least one alpha-numeric character
-- goto label label
-- Pops the top value from the stack ...
-- If the value is equal to 1, program execution switches to the first label ...
-- If the value equals 3, program execution switches to the second label ...
-- If the value does not equal 1 or 3, program execution continues to the next line
execute :: Interpreter -> Interpreter
execute finished@(Finished _ _ _ _ _) = finished
execute (Interpreter done (p@(Push x):rest) instr outstr stack) = Interpreter (done ++ [p]) rest instr outstr (push x stack)
execute (Interpreter done (p@Pop:rest) instr outstr stack) = Interpreter (done ++ [p]) rest instr outstr (pop stack)
execute (Interpreter done (p@Duplicate:rest) instr outstr stack) = Interpreter (done ++ [p]) rest instr outstr (duplicate stack)
execute (Interpreter done (p@Roll:rest) instr outstr stack) = Interpreter (done ++ [p]) rest instr outstr (roll stack)
execute (Interpreter done (p@In:rest) instr outstr stack) = Interpreter (done ++ [p]) rest instr' outstr stack'
where (instr', stack') = inop instr stack
execute (Interpreter done (p@Out:rest) instr outstr stack) = Interpreter (done ++ [p]) rest instr outstr' stack'
where (outstr', stack') = outop outstr stack
execute (Interpreter done (p@Add:rest) instr outstr stack) = Interpreter (done ++ [p]) rest instr outstr (add stack)
execute (Interpreter done (p@Subtract:rest) instr outstr stack) = Interpreter (done ++ [p]) rest instr outstr (subtractop stack)
execute (Interpreter done (p@Multiply:rest) instr outstr stack) = Interpreter (done ++ [p]) rest instr outstr (multiply stack)
execute (Interpreter done (p@Divide:rest) instr outstr stack) = Interpreter (done ++ [p]) rest instr outstr (divide stack)
execute (Interpreter done (p@Mod:rest) instr outstr stack) = Interpreter (done ++ [p]) rest instr outstr (modop stack)
execute (Interpreter done (p@Not:rest) instr outstr stack) = Interpreter (done ++ [p]) rest instr outstr (notop stack)
execute (Interpreter done (p@Greater:rest) instr outstr stack) = Interpreter (done ++ [p]) rest instr outstr (greater stack)
execute (Interpreter done (p@End:rest) instr outstr stack) = Finished (done ++ [p]) rest instr outstr stack
execute (Interpreter done (p@(Label _):rest) instr outstr stack) = Interpreter (done ++ [p]) rest instr outstr stack
execute (Interpreter done (p@Comment:rest) instr outstr stack) = Interpreter (done ++ [p]) rest instr outstr stack
execute (Interpreter done (p@(Goto label other):rest) instr outstr (x:stack)) = Interpreter done' rest' instr outstr stack
where (done', rest') = goto x (done ++ [p] ++ rest)
goto 1 prog = break (== (Label label)) prog
goto 3 prog = break (== (Label other)) prog
-- a script is a bunch of lines terminated by an EOF
qpScript :: GenParser Char st [Command]
qpScript = do result <- many line
eof
return result
-- a line contains a single command terminated by a eol (newline)
line :: GenParser Char st Command
line = do result <- command
eol
return result
-- a eol is a single \n char
eol :: GenParser Char st Char
eol = char '\n'
-- a command is a comment a label or an action
command :: GenParser Char st Command
command = comment <|> qpLabel <|> action
-- a comment is a # followed by zero or more chars
comment :: GenParser Char st Command
comment = do char '#'
many (noneOf "\n")
return Comment
-- a label is a : followed by zero or more alpha-numeric chars
qpLabel :: GenParser Char st Command
qpLabel = do char ':'
name <- many alphaNum
return (Label name)
action :: GenParser Char st Command
action = qpPush
<|> qpPop
<|> qpDuplicate
<|> qpRoll
<|> qpIn
<|> qpOut
<|> qpAdd
<|> qpSubtract
<|> qpMultiply
<|> qpDivide
<|> qpMod
<|> qpNot
<|> qpGreater
<|> qpEnd
<|> qpGoto
qpPush :: GenParser Char st Command
qpPush = do string "push"
x <- many digit
return (Push (read x))
qpPop = do string "pop"
return Pop
qpDuplicate = do string "duplicate"
return Duplicate
qpRoll = do string "roll"
return Roll
qpIn = do string "in"
return In
qpOut = do string "out"
return Out
qpAdd = do string "add"
return Add
qpSubtract = do string "subtract"
return Subtract
qpMultiply = do string "multiply"
return Multiply
qpDivide = do string "divide"
return Divide
qpMod = do string "mod"
return Mod
qpNot = do string "not"
return Not
qpGreater = do string "greater"
return Greater
qpEnd = do string "end"
return End
qpGoto = do string "goto"
label <- many alphaNum
char ' '
other <- many alphaNum
return (Goto label other)
parseQP :: String -> Either ParseError [Command]
parseQP input = parse qpScript "(unknown)" input
-- takes the list of commands to execute and stdin, returns stdout
runToCompletion :: [Command] -> String -> String
runToCompletion script instr = run (Interpreter script [] instr "" [])
where run (Finished _ _ _ outstr _) = outstr
run interpreter = run (execute interpreter)
-- the Main will take a filename, open it, parse it and pass the parsed commands to the interpreter
-- run the interpreter with the input and output hooked up to stdout and stdin should be simple :)
main = do (path:args) <- getArgs
contents <- readFile path
instr <- getContents
case parseQP contents of
Left err -> putStrLn $ "uh oh, error: " ++ (show err)
Right script -> let outstr = runToCompletion script instr in
putStr outstr
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment