Skip to content

@youngnh /QuickPiet.hs forked from benjaminplee/Piet! Language Spec
Created

Embed URL

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
-- 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
Something went wrong with that request. Please try again.