module Main
where
--- Copyright Brandon Simmons, 2010
--- http://coder.bsimmons.name/blog/
-- TODO:
-- performance improvements
-- consider switch over to IO Array or Vector?
-- catch errors in exec block
-- constrain grid to max proportions of array,
-- - expanding up to 80x25 when we have a 'p'
-- command outside the grid.
-- - Warn when we try to expand past 80x25, but
-- do expand.
-- helpers:
import System.Environment
import Data.Char
import Control.Arrow (first,second,(&&&),(|||))
-- we need to be able to modify our array efficiently
-- on 'p' calls. Using an IO Array would be easy here. For
-- now we use basic unboxed immutable array.
import Data.Array.Unboxed
-- we do a lot of work with IO in the State monad using StateT:
--- using 'mtl' library
import Control.Monad.State.Strict
--- using 'transformers' library: SLOWER THAN 'MTL'
--import Control.Monad.Trans.State.Strict
--import Control.Monad
--import Control.Monad.IO.Class
-- we need to be able to do randomness if we see '?':
import System.Random
-- error catching:
import System.IO
import System.IO.Error
--------------------------------------------------------------------------------
-- position of the "program counter":
type Position = (Int,Int)
-- directions as contintuations:
type Direction = Position -> Position
-- the source code is mapped onto a 2d array as Int ASCII values:
type Code = UArray Position Int
-- The stack stores integers, per the Funge-93 spec. When in "stringmode"
-- we push the ASCII value of the characters we read:
type Stack = [ Int ]
-- the state of our befunge program's execution. This is passed around
-- and modified as IO actions are performed:
data ProgramState =
ES { -- state of the code and stack:
code :: Code,
stack :: Stack,
-- state of program flow:
position :: Position,
direction :: Direction,
haltBit :: Bool,
-- random generator:
randGen :: StdGen,
-- should we announce messages and warnings?:
verbose :: Bool
}
-- the default initial state of a befunge computation:
defaultState = ES {
-- these are defaults:
haltBit = False,
position = (0,0),
direction = right,
stack = [],
randGen = mkStdGen 31337,
verbose = True,
code = array ((0,0),(0,0)) [] }
-- we are using the State monad for our plumbing, but we need to be in
-- the IO monad, so we use the State monad transformer! This is our
-- read-evaluate-print loop:
type REPL a = StateT ProgramState IO a
-- our command line paramaters:
data Opts = Opts { quiet :: Bool,
allow_oversize :: Bool,
seed :: Maybe Int,
srcFile :: FilePath }
-- by default we assume input is a correct funge-93 program:
defaultOpts = Opts False False Nothing ""
usage = "\n\tusage: " ++
"befunge-93 [--quiet] [--allow-oversize] [--seed INT] source.bf\n"
--------------------------------------------------------------------------------
--PROGRAM INITIALIZATION--
--------------------------------------------------------------------------------
main = do
-- parse command line options, then build our initial state for our befunge
-- computation, catching any IO errors in the process:
--state_i <- try $ processOpts . parseArgs =<< getArgs
args <- getArgs
opts <- either parsingErrors return (parseArgs args)
state_i <- try $ processOpts opts
-- it seems most programs expect input to be line-buffered:
hSetBuffering stdin LineBuffering
-- if there are errors, then print them and exit...
either processingErrors
-- else supply our initial state to the State/IO magic monadic
-- machinery and begin executing our befunge program:
(evalStateT evalLoop) state_i
--------------------------------------------------------------------------------
--EVALUATION LOOPS--
--------------------------------------------------------------------------------
evalLoop :: REPL ()
evalLoop = do
-- extract the command at our position & execute it:
getCmd >>= execute
-- halt if @ command issued, else move and recurse:
halting <- gets haltBit
unless halting (move >> evalLoop)
-- we push characters' ASCII values onto the stack until we hit " again:
stringModeLoop :: REPL ()
stringModeLoop = do
c <- getCmd
unless (c == '"') $ do
push (ord c)
move
stringModeLoop
-- this is the code that does all the work: a function which takes a program
-- state and does IO operations in the State/IO monads:
execute :: Char -> REPL ()
execute c =
case c of
-- stack operations: --
'+' -> do (a,b) <- pop2
push (a+b)
'-' -> do (a,b) <- pop2
push (b-a)
'*' -> do (a,b) <- pop2
push (a*b)
-- according to the befunge-98 spec, befunge-93 should ask the user
-- what the result of the division by zero should be. so elegant:
'/' -> do (a,b) <-pop2
safeZero b quot a >>= push
'%' -> do (a,b) <- pop2
safeZero b rem a >>= push
'!' -> do i <- pop
if i == 0
then push 1
else push 0
'`' -> do (a,b) <- pop2
if b>a
then push 1
else push 0
'$' -> do pop
return ()
-- Pop value and output as an integer. funge-98 spec calls for
-- integer to be followed by a space, so we'll do that too:
'.' -> do i <- pop
liftIO $ putStr $ show i ++" "
-- Pop value and output as ASCII character
',' -> do i <- pop
liftIO $ putChar $ chr i
'\\' -> do (a,b) <- pop2
push a
push b
':' -> do a <- pop
replicateM_ 2 (push a)
-- program flow commands: --
' ' -> return ()
'>' -> setDirection right
'<' -> setDirection left
'^' -> setDirection up
'v' -> setDirection down
'?' -> getRandomDirection >>= setDirection
-- hop over the next cell:
'#' -> move
'@' -> halt
-- stack and program flow: --
'"' -> move >> stringModeLoop
'_' -> do a <- pop
if a == 0
then setDirection right
else setDirection left
'|' -> do a <- pop
if a == 0
then setDirection down
else setDirection up
-- IO operations: --
'p' -> do (y,x) <- pop2
pop >>= putCell (x,y)
'g' -> do (y,x) <- pop2
getCell (x,y) >>= push
'&' -> liftIO askInt >>= push
'~' -> liftIO askChar >>= push
x -> if isDigit x
then push (digitToInt x)
-- halt and complain if invalid command:
else do loc <- gets position
halt
maybeSay$ "unknown command '" ++ show x ++
"' in code path at " ++ show loc ++
". Maybe you want a funge-98 interpreter?"
--------------------------------------------------------------------------------
-- LOOP HELPERS --
--------------------------------------------------------------------------------
-- -- -- SPECIAL ARITHMETIC -- -- --
safeZero :: Int -> (Int -> Int -> Int) -> Int -> REPL Int
safeZero b func a =
if a /= 0
then return (b `func` a)
else do liftIO $ putStr
"\ndiv by zero; enter desired Int result: "
liftIO askInt
-- -- -- STACK HELPERS -- -- --
-- when empty stack, we are supposed to pop 0:
pop :: REPL Int
pop = do
st <- gets stack
if null st
then return 0
else do modify $ \s-> s{stack = tail st}
return (head st)
pop2 :: REPL (Int,Int)
pop2 = do a <- pop
b <- pop
return (a,b)
push :: Int -> REPL ()
push c = modify $ \s-> s{stack = c : stack s}
-- -- -- MISC STATE HELPERS -- -- --
-- the command character at our position:
getCmd :: REPL Char
getCmd = do p <- gets position
gets (chr . (! p) . code)
getCell :: Position -> REPL Int
getCell xy = do
xy' <- wrap xy
unless (xy == xy') (maybeSay "warning: getCell out of bounds. wrapping.")
gets ((! xy') . code)
-- modify our array by changing its value at position xy:
putCell :: Position -> Int -> REPL ()
putCell xy c = do
xy' <- wrap xy
unless (xy == xy') (maybeSay "warning: putCell out of bounds. wrapping.")
a <- gets code
modify $ \s-> s{code = a//[(xy',c)] }
-- update state with new seed, returning a random direction:
getRandomDirection :: REPL Direction
getRandomDirection = do
(i,g) <- gets (randomR (0,3) . randGen)
modify $ \s-> s{randGen = g}
return ([up,down,left,right] !! i)
-- -- -- PROGRAM FLOW HELPERS -- -- --
halt :: REPL ()
halt = modify $ \s-> s{ haltBit = True }
setDirection :: Direction -> REPL ()
setDirection d = modify $ \s-> s{direction = d}
move :: REPL ()
move = do
-- we need to know when we're out of bounds, so we can wrap:
(pos,mv) <- gets (position &&& direction)
pos' <- wrapSimple (mv pos)
modify $ \s-> s{position = pos'}
-- if we exceed bounds, we wrap like a torus:
wrap :: Position -> REPL Position
wrap (pX,pY) = do
(bX,bY) <- gets (snd . bounds . code)
let x = pX `mod` (bX+1)
y = pY `mod` (bY+1)
return (x,y)
-- DIFFICULT TO TELL IF THIS IS SIGNIFICANTLY FASTER THAN `wrap`:
-- a more efficient wrapping function, for the program counter. Because
-- the PC moves only one space at a time, we can use this in the 'move'
-- function:
wrapSimple :: Position -> REPL Position
wrapSimple (pX,pY) = do
(bX,bY) <- gets (snd . bounds . code)
let x | pX < 0 = bX
| pX > bX = 0
| otherwise = pX
y | pY < 0 = bY
| pY > bY = 0
| otherwise = pY
return (x,y)
-- we use continuations for the direction, because we never need to inspect
-- our direction, thus a function is appropriate:
down, up, left, right :: Direction
down = second (+1)
right = first (+1)
left = first (subtract 1)
up = second (subtract 1)
-- -- -- IO HELPERS -- -- --
askInt :: IO Int
askInt = do n <- getLine
if isInt n
then return (read n)
else putStr "NOT AN INT. Try again: " >> askInt
askChar :: IO Int
askChar = getChar >>= return . ord
isInt :: String -> Bool
isInt = all isDigit
-- -- -- ERROR AND DEBUGGING HELPERS -- -- --
maybeSay :: String -> REPL ()
maybeSay m = do
v <- gets verbose
when v (liftIO $ putStrLn m )
--------------------------------------------------------------------------------
-- MAIN IO HELPERS --
--------------------------------------------------------------------------------
-- -- -- CLI ARGUMENTS PROCESSING -- -- --
-- convert user-supplied options in our Opt container into
-- an initial state, in the IO monad:
processOpts :: Opts -> IO ProgramState
processOpts os = do
let loud = not $ quiet os -- print warnings
bigOk = allow_oversize os -- okay if grid is oversize
-- build code grid from source file; we return the code array
-- and a Bool set to True if the input file was larger than the
-- standard 80x25:
hdl <- openFile (srcFile os) ReadMode
-- This should be compatible with UTF-8, and any symbols outside
-- the allowed Funge-93 charset will raise an error in `execute`:
hSetEncoding hdl latin1
src <- hGetContents hdl
let (wasBig,arr) = buildGrid bigOk src
-- initialize the RNG either from user-supplied seed, or
-- with the system generator:
rng <- maybe getStdGen (return . mkStdGen) (seed os)
when (loud && wasBig) $ putStrLn $
if bigOk
then "WARNING: using code area larger than 80x25."
else "WARNING: source was truncated to 80x25; " ++
"use --allow-oversize for source code of " ++
"arbitrary dimensions."
return$ defaultState{ code = arr,
randGen = rng,
verbose = loud }
-- we catch only errors of parsing the command line arguments here.
-- btw this frankly seems easier than System.Console.GetOpts:
parseArgs :: [String] -> Either IOError Opts
parseArgs [] = Left$ userError$ "SOURCE FILE REQUIRED:"++ usage
parseArgs as = parse as defaultOpts
where -- the source code file:
parse [src] opts = Right$ opts{srcFile = src}
-- simple optional flags:
parse ("--quiet":as) os = parse as os{quiet = True}
parse ("--allow-oversize":as) os = parse as os{allow_oversize = True}
-- options with args:
parse ("--seed":s:as) os =
if isInt s
then parse as os{seed = Just$ read s}
else Left$ userError$ "SEED MUST BE AN INTEGER:"++usage
-- parse errors:
parse _ _ = Left$ userError $ "ERROR PARSING OPTIONS"++usage
-- -- -- INPUT PROCESSING -- -- --
-- returns the array of source code, along with a Bool denoting whether
-- the input source file exceeded 80x25 in any of it's dimensions:
buildGrid :: Bool -> String -> (Bool,Code)
buildGrid allowing_oversize str =
let ls = lines $ fixLineBreaks str
-- our array must be at least 80x25, but we will expand it if
-- the source seems to exceed those dimensions anywhere:
sxN = maximum $ 79 : map (subtract 1 . length) ls
syN = max 24 (length ls - 1)
(xN,yN) = if allowing_oversize
then (sxN, syN)
else (79,24)
-- we pad the array with spaces:
pad = repeat ' '
ls' = take (yN+1) (ls ++ repeat pad)
-- array is indexed from (0,0) in the upper left corner:
coords = [ (x,y) | y <- [0..yN], x <- [0..xN] ]
cells = map ord $ concatMap (take (xN+1) . (++pad)) ls'
-- was the source input bigger than 80x25?:
big = sxN > 79 || syN > 24
arr = array ((0,0),(xN,yN)) (zip coords cells)
in (big, arr)
--------------------------------------------------------------------------------
-- ERROR AND FILE HANDLING --
--------------------------------------------------------------------------------
-- convert all three line break types to newlines. This isn't required by
-- the spec, but is useful:
fixLineBreaks :: String -> String
fixLineBreaks [] = []
fixLineBreaks ('\r':'\n':xs) = '\n' : fixLineBreaks xs --win
fixLineBreaks ('\r':xs) = '\n' : fixLineBreaks xs --old mac
fixLineBreaks (x:xs) = x : fixLineBreaks xs
-- minimal error handling. An error here seems to mean File Encoding
-- issues:
processingErrors :: IOError -> IO ()
processingErrors e = do
print e
putStrLn "* Please report this bug to me so I can fix it *"
-- raise the error retuned by the parsing function: parseArgs
parsingErrors :: IOError -> IO a
parsingErrors = ioError