Name: Anonymous 2012-01-23 7:24
/program/, help me. I'm learning Haskell, and I love it. What can I do to rectify my correct opinion that functional programming is a wonderful and powerful tool?
int main(int argc, char **argv) {
char* code = argv[1], data = 0, *p = &data;
while(*code)
switch(*code++) {
case '>': ++p; break;
case '<': --p; break;
case '+': ++(*p); break;
case '-': --(*p); break;
case '.': putchar(*p); break;
case ',': *p = getchar(); break;
}
}
module Language.Brainfuck where
import Data.Array.IO
import Data.Array hiding (array)
import Data.Array.Base (unsafeRead, unsafeWrite, array)
import Data.Word ( Word8 )
import Data.Char ( ord, chr )
import Data.List ( groupBy )
import Data.Maybe ( catMaybes )
import Control.Monad.State
{- | The complete BF language:
* \> Increment the pointer.
* \< Decrement the pointer.
* + Increment the byte at the pointer.
* \- Decrement the byte at the pointer.
* . Output the byte at the pointer.
* , Input a byte and store it in the byte at the pointer.
* [ Jump forward past the matching ] if the byte at the pointer is zero.
* ] Jump backward to the matching [ unless the byte at the pointer is zero.
-}
data Command = IncPtr
| IncPtrBy !Int -- ^ Increment pointer by set amount
| DecPtr
| IncByte
| IncByteBy !Int -- ^ Increment by a set amount
| DecByte
| OutputByte
-- | InputByte
| JmpForward !Int -- ^ nesting level
| JmpBackward !Int -- ^ nesting level
| SetIpTo !Int -- ^ Sets the instruction ptr to a specific value
| Halt
| Ignored
deriving (Show, Eq)
type Core = IOUArray Int Word8
type InstPtr = Int
type CorePtr = Int
data BF = BF !Core !CorePtr !InstPtr
instance Show BF where
show (BF _ cp ip) = "BF <core> CorePtr = " ++ show cp ++ " InstPtr = " ++ show ip
coreSize = 30000
core :: IO Core
core = newArray (0, coreSize - 1) (0::Word8)
decode :: Char -> State Int Command
decode '>' = return IncPtr
decode '<' = return DecPtr
decode '+' = return IncByte
decode '-' = return DecByte
decode '.' = return OutputByte
-- decode ',' = return InputByte
decode '[' = do n <- get
put (n+1)
return $ JmpForward n
decode ']' = do n <- get
put (n-1)
return $ JmpBackward (n-1)
decode '@' = return Halt
decode _ = return Ignored
debug :: Bool
debug = False
incIP :: InstPtr -> InstPtr
incIP = (+ 1)
{-# INLINE incIP #-}
incCP :: CorePtr -> CorePtr
incCP = (`mod` coreSize) . (1 +)
{-# inlinE incCP #-}
decCP :: CorePtr -> CorePtr
decCP = (`mod` coreSize) . subtract 1
{-# INLINE decCP #-}
doCommand :: Array Int Command -> BF -> IO BF
doCommand cmds bf@(BF _ _ ip) = doCommand' (cmds ! ip) cmds bf
where
doCommand' :: Command -> Array Int Command -> BF -> IO BF
doCommand' Halt _ _ = undefined
doCommand' Ignored _ (BF c cp ip) = {-# SCC "Ignored" #-} do
when debug $ putStrLn $ "Ignored " ++ show bf
return (BF c cp (incIP ip))
doCommand' IncPtr _ bf@(BF c cp ip) = {-# SCC "IncPtr" #-} do
when debug $ putStrLn $ "IncPtr " ++ show bf
return (BF c (incCP cp) (incIP ip))
doCommand' DecPtr _ bf@(BF c cp ip) = {-# SCC "DecPtr" #-} do
when debug $ putStrLn $ "DecPtr " ++ show bf
return (BF c (decCP cp) (incIP ip))
doCommand' (IncPtrBy n) _ bf@(BF c cp ip) = {-# SCC "IncPtrBy" #-} do
when debug $ putStrLn $ "IncPtrBy " ++ show n ++ " " ++ show bf
return (BF c ((cp + n) `mod` coreSize) (incIP ip))
doCommand' IncByte _ bf = {-# SCC "IncByte" #-} do
when debug $ putStrLn $ "IncByte " ++ show bf
updateByte bf (+1)
doCommand' DecByte _ bf = {-# SCC "DecByte" #-} do
when debug $ putStrLn $ "DecByte " ++ show bf
updateByte bf (subtract 1)
doCommand' (IncByteBy n) _ bf = {-# SCC "IncByteBy" #-} do
when debug $ putStrLn $ "IncByteBy " ++ show n ++ " " ++ show bf
updateByte bf (+ fromIntegral n)
doCommand' OutputByte _ bf@(BF c cp ip) = {-# SCC "OutputByte" #-} do
when debug $ putStrLn $ "OutputByte " ++ show bf
c' <- unsafeRead c cp
putChar (word8ToChr c')
return (BF c cp (incIP ip))
{-
doCommand' InputByte _ bf@(BF c cp ip) = {-# SCC "InputByte" #-} do
when debug $ putStrLn $ "InputByte " ++ show bf
c' <- getChar
let newByte = chrToWord8 c'
unsafeWrite c cp newByte
return (BF c cp (incIP ip))
-}
doCommand' (JmpForward n) cmds bf@(BF c cp ip) = {-# SCC "JmpForw" #-} do
c' <- unsafeRead c cp
case c' of
0 -> {-# SCC "JmpForward1" #-} do
when debug $ putStrLn $ "JmpForward1 " ++ show bf
return (BF c cp newInstPtr)
_ -> {-# SCC "JmpForward2" #-} do
when debug $ putStrLn $ "JmpForward2 " ++ show bf
let newBF = (BF c cp (incIP ip))
when debug $ putStrLn $ "JmpForward3" ++ show newBF
return newBF
where
-- we add one to go one past the next back jump
newInstPtr = (nextJmp cmds ip (+1) (JmpBackward n)) + 1
doCommand' (JmpBackward n) cmds bf@(BF c cp ip) = {-# SCC "JmpBack" #-} do
c' <- unsafeRead c cp
if (c' /= 0)
then do when debug $ putStrLn $ "JmpBackward1 " ++ show bf
return (BF c cp newInstPtr)
else do when debug $ putStrLn $ "JmpBackward2 " ++ show bf
return (BF c cp (incIP ip))
where
newInstPtr = nextJmp cmds ip (subtract 1) (JmpForward n)
doCommand' (SetIpTo i) _ bf@(BF c cp ip) = {-# SCC "SetIPTo" #-} do
c' <- unsafeRead c cp
when debug $ putStrLn $ "SetIpTo " ++ show i ++ " "
++ show bf ++ " @" ++ show c'