Befunge.hs

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