/Brainfuck.hs
Haskell | 71 lines | 55 code | 12 blank | 4 comment | 1 complexity | 3b67a9685c7039adfd2add9d22de2e0e MD5 | raw file
- import Control.Monad.State
- import Data.Char
- import Data.Maybe
- import Data.Word
- import Text.ParserCombinators.Parsec ( Parser, parse, many, oneOf
- , noneOf, between, char, (<|>))
- -- zipper
- data ListZipper a = ListZipper { getLeft :: [a]
- , getValue :: a
- , getRight :: [a]
- } deriving Show
- modifyValue :: (a -> a) -> ListZipper a -> ListZipper a
- modifyValue f (ListZipper ls x rs) = ListZipper ls (f x) rs
- forward :: ListZipper a -> ListZipper a
- forward (ListZipper ls x (r:rs)) = ListZipper (x:ls) r rs
- backward :: ListZipper a -> ListZipper a
- backward (ListZipper (l:ls) x rs) = ListZipper ls l (x:rs)
- -- brainfuck
- data BFIns = Next | Prev | Inc | Dec | Read | Write | Loop [BFIns]
- deriving Show
- type BFCell = Word8
- type BFState = ListZipper BFCell
- type Brainfuck = StateT BFState IO
- emptyState :: BFState
- emptyState = ListZipper zeroes 0 zeroes
- where zeroes = repeat 0
- eval :: BFIns -> Brainfuck ()
- eval Next = modify forward
- eval Prev = modify backward
- eval Inc = modify $ modifyValue (+1)
- eval Dec = modify . modifyValue $ subtract 1
- eval Write = gets getValue >>= liftIO . putStr . return . chr . fromEnum
- eval Read = liftIO getChar >>= modify . modifyValue . const . toEnum . ord
- eval loop@(Loop inside) = gets getValue >>= executeLoop
- where executeLoop val | val == 0 = return ()
- | otherwise = mapM_ eval $ inside ++ [loop]
- runBF :: [BFIns] -> IO BFState
- runBF = flip execStateT emptyState . mapM_ eval
- -- parser
- comment :: Parser (Maybe BFIns)
- comment = noneOf "]" >> return Nothing
- simpleIns :: Parser (Maybe BFIns)
- simpleIns = oneOf "<>+-.," >>= \ins -> return . Just $ case ins of
- '<' -> Next
- '>' -> Prev
- '+' -> Inc
- '-' -> Dec
- '.' -> Write
- ',' -> Read
- loop :: Parser (Maybe BFIns)
- loop = between (char '[') (char ']') (program >>= return . Just . Loop)
- program :: Parser [BFIns]
- program = liftM catMaybes $ many $ simpleIns <|> loop <|> comment
- -- utility
- parseAndRunBF :: String -> IO ()
- parseAndRunBF str = do let parseRes = parse program "bf" str
- case parseRes of
- Left err -> putStrLn ("Syntax error: " ++ show err)
- Right ins -> runBF ins >> putStrLn ""