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
data Command = IncPtr
| IncPtrBy !Int
| DecPtr
| IncByte
| IncByteBy !Int
| DecByte
| OutputByte
| JmpForward !Int
| JmpBackward !Int
| SetIpTo !Int
| 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 '[' = do n <- get
put (n+1)
return $ JmpForward n
decode ']' = do n <- get
put (n1)
return $ JmpBackward (n1)
decode '@' = return Halt
decode _ = return Ignored
debug :: Bool
debug = False
incIP :: InstPtr -> InstPtr
incIP = (+ 1)
incCP :: CorePtr -> CorePtr
incCP = (`mod` coreSize) . (1 +)
decCP :: CorePtr -> CorePtr
decCP = (`mod` coreSize) . subtract 1
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) = do
when debug $ putStrLn $ "Ignored " ++ show bf
return (BF c cp (incIP ip))
doCommand' IncPtr _ bf@(BF c cp ip) = do
when debug $ putStrLn $ "IncPtr " ++ show bf
return (BF c (incCP cp) (incIP ip))
doCommand' DecPtr _ bf@(BF c cp ip) = do
when debug $ putStrLn $ "DecPtr " ++ show bf
return (BF c (decCP cp) (incIP ip))
doCommand' (IncPtrBy n) _ bf@(BF c cp ip) = do
when debug $ putStrLn $ "IncPtrBy " ++ show n ++ " " ++ show bf
return (BF c ((cp + n) `mod` coreSize) (incIP ip))
doCommand' IncByte _ bf = do
when debug $ putStrLn $ "IncByte " ++ show bf
updateByte bf (+1)
doCommand' DecByte _ bf = do
when debug $ putStrLn $ "DecByte " ++ show bf
updateByte bf (subtract 1)
doCommand' (IncByteBy n) _ bf = do
when debug $ putStrLn $ "IncByteBy " ++ show n ++ " " ++ show bf
updateByte bf (+ fromIntegral n)
doCommand' OutputByte _ bf@(BF c cp ip) = do
when debug $ putStrLn $ "OutputByte " ++ show bf
c' <- unsafeRead c cp
putChar (word8ToChr c')
return (BF c cp (incIP ip))
doCommand' (JmpForward n) cmds bf@(BF c cp ip) = do
c' <- unsafeRead c cp
case c' of
0 -> do
when debug $ putStrLn $ "JmpForward1 " ++ show bf
return (BF c cp newInstPtr)
_ -> do
when debug $ putStrLn $ "JmpForward2 " ++ show bf
let newBF = (BF c cp (incIP ip))
when debug $ putStrLn $ "JmpForward3" ++ show newBF
return newBF
where
newInstPtr = (nextJmp cmds ip (+1) (JmpBackward n)) + 1
doCommand' (JmpBackward n) cmds bf@(BF c cp ip) = 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) = do
c' <- unsafeRead c cp
when debug $ putStrLn $ "SetIpTo " ++ show i ++ " "
++ show bf ++ " @" ++ show c'
if i > 0
then if (c' == 0)
then return $ BF c cp i
else return $ BF c cp (incIP ip)
else if (c' /= 0)
then return $ BF c cp (i)
else return $ BF c cp (incIP ip)
nextJmp :: Array Int Command
-> InstPtr
-> (InstPtr -> InstPtr) -> Command -> InstPtr
nextJmp cmds ip f cmd = if cmds ! ip == cmd
then ip
else nextJmp cmds (f ip) f cmd
chrToWord8 :: Char -> Word8
chrToWord8 = fromIntegral . ord
word8ToChr :: Word8 -> Char
word8ToChr = chr . fromIntegral
updateByte (BF c cp ip) f = do
e <- unsafeRead c cp
unsafeWrite c cp (f e)
return (BF c cp (incIP ip))
loadProgram :: String -> Array Int Command
loadProgram [] = array (0, 0) [(0, Halt)]
loadProgram prog = optimize (cs++[Halt])
where
cs = fst $ runState (mapM decode prog) 0
n = length cs
optimize :: [Command] -> Array Int Command
optimize cmds = listArray (0, (length reduced)1) reduced
where
reduced = phase3 . phase2 . phase1 $ cmds
phase1 :: [Command] -> [Command]
phase1 = filter (/=Ignored)
phase2 :: [Command] -> [Command]
phase2 cs = concat $ map reduce $ groupBy (==) cs
where
reduce :: [Command] -> [Command]
reduce cs
| all (==IncPtr) cs = [IncPtrBy (length cs)]
| all (==DecPtr) cs = [IncPtrBy ((length cs))]
| all (==IncByte) cs = [IncByteBy (length cs)]
| all (==DecByte) cs = [IncByteBy ((length cs))]
| otherwise = cs
phase3 :: [Command] -> [Command]
phase3 cmds = updates (updates cmds jmpBs) jmpFs
where
jmpBs = calcJmpBs (zip [0..] cmds)
jmpFs = calcJmpFs (zip [0..] cmds)
update :: [a] -> (Int, a) -> [a]
update xs (i, a) = take i xs ++ [a] ++ drop (i+1) xs
updates :: [a] -> [(Int, a)] -> [a]
updates xs [] = xs
updates xs (u:us) = updates (update xs u) us
nested :: Command -> Int
nested (JmpForward n) = n
nested (JmpBackward n) = n
nested _ = undefined
isJmpB (JmpBackward _) = True
isJmpB _ = False
isJmpF (JmpForward _) = True
isJmpF _ = False
calcJmpBs :: [(Int, Command)] -> [(Int, Command)]
calcJmpBs cmds = catMaybes $ map newCmd (filter (isJmpB . snd) cmds)
where
newCmd (i, c) = absJmpB (i, findPrevJmpF (map snd cmds) i (nested c))
calcJmpFs :: [(Int, Command)] -> [(Int, Command)]
calcJmpFs cmds = catMaybes $ map newCmd (filter (isJmpF . snd) cmds)
where
newCmd (i, c) = absJmpF (i, findNextJmpB (map snd cmds) i (nested c))
absJmpB :: (Int, Maybe Int) -> Maybe (Int, Command)
absJmpB (_, Nothing) = Nothing
absJmpB (i, Just n) = Just $ (i, SetIpTo (n))
absJmpF (_, Nothing) = Nothing
absJmpF (i, Just n) = Just $ (i, SetIpTo (n+1))
findPrevJmpF :: [Command]
-> Int
-> Int
-> Maybe Int
findPrevJmpF _ i _ | i < 0 = Nothing
findPrevJmpF cmds i n = case (cmds !! i) of
(JmpForward l) | l == n -> Just i
_ -> findPrevJmpF cmds (i1) n
findNextJmpB :: [Command]
-> Int
-> Int
-> Maybe Int
findNextJmpB cmds i _ | i >= length cmds = Nothing
findNextJmpB cmds i n = case (cmds !! i) of
(JmpBackward l) | l == n -> Just i
_ -> findNextJmpB cmds (i+1) n
execute :: Array Int Command -> Int -> BF -> IO ()
execute cmds n bf@(BF _ _ ip) = do
if ip >= n || cmds ! ip == Halt
then halt
else doCommand cmds bf >>= execute cmds n
halt = if debug
then putStrLn "Machine Halted.\n"
else putStrLn "\n"