Skip to content

Instantly share code, notes, and snippets.

@nonowarn
Created February 11, 2010 03:47
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save nonowarn/301189 to your computer and use it in GitHub Desktop.
Save nonowarn/301189 to your computer and use it in GitHub Desktop.
Brainf**k Interpreter
{-# LANGUAGE BangPatterns #-}
import Control.Applicative
import System.Environment
data Tape = T { current :: !Int, lefts, rights :: [Int] }
inc, dec, left, right :: Tape -> Tape
inc (T c ls rs) = T (c+1) ls rs
dec (T c ls rs) = T (c-1) ls rs
left (T c (l:ls) rs) = T l ls (c:rs)
right (T c ls (r:rs)) = T r (c:ls) rs
set :: Int -> Tape -> Tape
set c (T _ ls rs) = T c ls rs
get :: IO Int; put :: Int -> IO ()
get = fromEnum <$> getChar
put = putChar . toEnum
run :: String -> IO Tape
run str = run' str $ T 0 cells cells
where
run' cs = go cs return
go [] k = k
go (c:cs) k = case c of
'>' -> go cs (fmap right . k)
'<' -> go cs (fmap left . k)
'+' -> go cs (fmap inc . k)
'-' -> go cs (fmap dec . k)
'.' -> go cs ((liftA2 (>>) (put . current) return =<<) . k)
',' -> go cs (((<$> get) . flip set =<<) . k)
'[' -> let (loop,rest) = find_loop cs
in go rest ((untilM ((==0) . current) (run' loop) =<<) . k)
_ -> go cs k
cells = repeat 0
runBrainfuck :: String -> IO ()
runBrainfuck bf = do run bf; return ()
-- helloworld = "+++++++++[>++++++++>+++++++++++>+++++<<<-]>.>++.+++++++..+++.>-."
-- ++ "------------.<++++++++.--------.+++.------.--------.>+."
untilM :: (Monad m) => (a -> Bool) -> (a -> m a) -> a -> m a
untilM p k a | p a = return a
| otherwise = k a >>= untilM p k
find_loop cs =
let f 0 (']':r) = ("", r)
f n (']':r) = let ~(l,r') = f (n-1) r in (']':l,r')
f n ('[':r) = let ~(l,r') = f (n+1) r in ('[':l,r')
f n (c:cs) = let ~(l,r') = f n cs in (c:l, r')
in f 0 cs
main = fmap head getArgs >>= readFile >>= runBrainfuck
bf: bf.hs
ghc --make -O2 bf
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment