Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
Brainf*ck in Haskell
import Data.Char (chr)
brainfuck :: String -> IO String
brainfuck cmds = loop ([], (return 0), (repeat $ return 0)) 0 []
where
max = length cmds
loop :: ([IO Int], IO Int, [IO Int]) -> Int -> [IO Char] -> IO String
loop (xs,y,zs) index outs
| index == max = sequence (reverse outs)
| otherwise = cnd (cmds !! index)
where
cnd '>' = loop ((y:xs), (head zs), tail zs) (index+1) outs
cnd '<' = loop (tail xs, (head xs), (y:zs)) (index+1) outs
cnd '+' = loop (xs, (+ 1) <$> y, zs) (index+1) outs
cnd '-' = loop (xs, (+ (-1)) <$> y, zs) (index+1) outs
cnd '.' = loop (xs, y, zs) (index+1) ((chr <$> y):outs)
cnd ',' = loop (xs, read <$> getLine, zs) (index+1) outs
cnd '[' = let diff = serch '[' ']' (drop (index+1) cmds) in
do y' <- y
if y' == 0 then
loop (xs, y, zs) (index+diff+1) outs
else
loop (xs, y, zs) (index+1) outs
cnd ']' = let diff = serch ']' '[' (reverse $ take index cmds) in
do y' <- y
loop (xs, y, zs) (index-diff) outs
cnd _ = loop (xs, y, zs) (index+1) outs
serch :: Char -> Char -> [Char] -> Int
serch a b cmds = loop 1 0 cmds
where
loop 0 i _ = i
loop n i (l:ls)
| l == a = loop (n+1) (i+1) ls
| l == b = loop (n-1) (i+1) ls
| otherwise = loop n (i+1) ls
main = getContents >>= brainfuck . concat . lines >>= putStrLn
module Main where
import Data.Char (chr, ord)
import System.Environment (getArgs)
main :: IO ()
main = do
[filepath] <- getArgs
prog <- readFile filepath
_ <- run $ initMachine prog
putStrLn ""
data Machine =
Machine { programOf :: Program, memOf :: Tape Int } deriving (Show)
data Tape a = Tape { front :: [a], current :: a, back :: [a] } deriving (Show)
type Program = Tape (Maybe Char)
mapCrr :: (a -> a) -> Tape a -> Tape a
mapCrr f tape = tape { current = f (current tape) }
moveFront :: Tape a -> Tape a
moveFront (Tape [] _ _) = error "front is empty."
moveFront (Tape f c b) = Tape (tail f) (head f) (c : b)
moveBack :: a -> Tape a -> Tape a
moveBack a (Tape f c []) = Tape (c : f) a []
moveBack _ (Tape f c b) = Tape (c : f) (head b) (tail b)
initMachine :: String -> Machine
initMachine = initMachine' . flip mappend [fin] . fmap Just
where
initMachine' s = Machine (Tape [] (head s) (tail s)) (Tape [] 0 [])
fin :: Maybe Char
fin = Nothing
run :: Machine -> IO Machine
run = loopM run' ((/=) fin . current . programOf)
loopM :: Monad m => (a -> m a) -> (a -> Bool) -> a -> m a
loopM f p a = if p a then f a >>= loopM f p else return a
run' :: Machine -> IO Machine
run' m@(Machine prog mem) =
(\m' -> m' { programOf = moveBack' $ programOf m' }) <$> cond (current prog)
where
cond (Just '>') = return $ Machine prog (moveBack 0 mem)
cond (Just '<') = return $ Machine prog (moveFront mem)
cond (Just '+') = return $ Machine prog (mapCrr (+ 1) mem)
cond (Just '-') = return $ Machine prog (mapCrr (+ (-1)) mem)
cond (Just '.') = return m <* putChar (chr $ current mem)
cond (Just ',') =
(\c -> Machine prog (mapCrr (const $ ord c) mem)) <$> getChar
cond (Just '[') = return . flip Machine mem $
(if current mem == 0 then jump ('[', ']') moveBack' else id) prog
cond (Just ']') = return . flip Machine mem $
(if current mem /= 0 then jump (']', '[') moveFront else id) prog
cond _ = return m
moveBack' = moveBack fin
jump :: (Char, Char) -> (Program -> Program) -> Program -> Program
jump (a, b) f = go 1
where
go 0 prog = prog
go n prog = go (updateCounter (p a) (p b) (current $ f prog) n) (f prog)
p x = (==) (Just x)
updateCounter :: (a -> Bool) -> (a -> Bool) -> a -> Int -> Int
updateCounter p q a = (+) (if p a then 1 else if q a then -1 else 0)
+++++++++[>++++++++>+++++++++++>+++++<<<-]>.>++.+++++++..+++.>-.
------------.<++++++++.--------.+++.------.--------.>+.
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment