QuickPiet.hs

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