public
Last active — forked from benjaminplee/Piet! Language Spec

  • Download Gist
QuickPiet.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286
-- 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

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.