Skip to content

Instantly share code, notes, and snippets.

@masterdezign

masterdezign/brainf.hs

Last active Aug 30, 2017
Embed
What would you like to do?
Brainf**k interpreter in Haskell.
{-
Brainf**k interpreter
Instructions:
> Increment data pointer so that it points to next location in memory.
< Decrement data pointer so that it points to previous location in memory.
+ Increment the byte pointed by data pointer by 1. If it is already at its maximum value, 255, then new value will be 0.
- Decrement the byte pointed by data pointer by 1. If it is at its minimum value, 0, then new value will be 255.
. Output the character represented by the byte at the data pointer.
, Read one byte and store it at the memory location pointed by data pointer.
[ If the byte pointed by data pointer is zero, then move instruction pointer to next matching ']', otherwise move instruction pointer to next command.
] If the byte pointed by data pointer is non-zero, then move instruction pointer to previous matching '[' command, otherwise to next command.
Example. The first line of hello-world.bf must contain the input ('$' means there is no input).
hello-world.bf:
$
+++++ +++++ initialize counter (cell #0) to 10
[ use loop to set the next four cells to 70/100/30/10
> +++++ ++ add 7 to cell #1
> +++++ +++++ add 10 to cell #2
> +++ add 3 to cell #3
> + add 1 to cell #4
<<<< - decrement counter (cell #0)
]
> ++ . print 'H'
> + . print 'e'
+++++ ++ . print 'l'
. print 'l'
+++ . print 'o'
> ++ . print ' '
<< +++++ +++++ +++++ . print 'W'
> . print 'o'
+++ . print 'r'
----- - . print 'l'
----- --- . print 'd'
> + . print '!'
$ ghc -O2 brainf.hs
$ ./brainf < hello-world.bf
Hello World!
-}
{-# LANGUAGE BangPatterns #-}
import Data.Word ( Word8 )
import Data.Char ( chr )
import Control.Applicative
import Control.Arrow
import Text.Printf
type Program = [BFInstruction]
data BFInstruction = BFNext | BFPrev -- memory movements
| BFInc | BFDec -- increment / decrement
| BFPut | BFGet -- to stdout / from stdin
| BFLoop Program -- loops
deriving Show
newtype Input = Input String
newtype Output = Output String
parse [] = Right []
parse (x:xs) =
case x of
'>' -> BFNext <$:> parse xs
'<' -> BFPrev <$:> parse xs
'+' -> BFInc <$:> parse xs
'-' -> BFDec <$:> parse xs
'.' -> BFPut <$:> parse xs
',' -> BFGet <$:> parse xs
'[' -> case _lp xs 0 of
Left s -> Left s
Right (lp, xs') -> BFLoop `fmap` parse lp <:> parse xs'
-- ']' is already handled by _lp
']' -> Left "Unexpected ']'"
_ -> parse xs
_lp :: String -> Int -> Either String (String, String)
_lp [] _ = Left "Unclosed '['"
_lp (']':xs) 0 = Right ([], xs)
_lp (']':xs) lvl = ']' <$:-> _lp xs (lvl + 1)
_lp ('[':xs) lvl = '[' <$:-> _lp xs (lvl - 1)
_lp (x:xs) lvl = x <$:-> _lp xs lvl
x <$:> xs = fmap (x:) xs
x <$:-> xs = fmap (first (x:)) xs
(<:>) = liftA2 (:)
data Tape a = Tape { memL :: [a], cell :: a, memR :: [a] }
forward :: Tape a -> Tape a
forward Tape { memL = memL, cell = cell, memR = (mr:mrs) } = Tape { memL = cell : memL, cell = mr, memR = mrs }
backward :: Tape a -> Tape a
backward Tape { memL = (ml:mls), cell = cell, memR = memR } = Tape { memL = mls, cell = ml, memR = cell : memR }
modify :: (a -> a) -> Tape a -> Tape a
modify f t@Tape { cell = cell} = t { cell = f cell }
value :: Tape Word8 -> Word8
value Tape { cell = cell } = cell
pu :: Tape Word8 -> (BFInstruction, Input) -> (Tape Word8, Input, Output)
pu t (i, input@(Input inp)) =
case i of
BFInc -> taped $ modify (+1) t
BFDec -> taped $ modify (subtract 1) t
BFPrev -> taped $ backward t
BFNext -> taped $ forward t
BFGet -> let t' = modify (const . toWord8 . head $ inp) t
in (t', Input $ tail inp, Output "")
BFPut -> (t, input, Output (toString $ value t))
BFLoop p -> bfloop p t input
where
taped t' = (t', input, Output "") -- No output, no input consumption
bfloop p' t' input' | value t' == 0 = taped t'
| otherwise = let (t1, input1, Output out1) = interpret p' t' input'
(t2, input2, Output out2) = bfloop p' t1 input1
in (t2, input2, Output (out1 ++ out2))
-- TODO: count the number of operations
-- interpr :: Program -> Tape -> Int -> Input -> (Tape, Input, Output)
interpret :: Program -> Tape Word8 -> Input -> (Tape Word8, Input, Output)
interpret [] t input = (t, input, Output "")
interpret (i:ins) t input = (t2, input2, Output (out ++ out2))
where (t1, input1, Output out) = pu t (i, input)
(t2, input2, Output out2) = interpret ins t1 input1
toWord8 :: Char -> Word8
toWord8 = fromIntegral . fromEnum
toString :: Word8 -> String
toString = (:[]) . chr . fromIntegral
initial :: Tape Word8
initial = Tape { memL = repeat 0, cell = 0, memR = repeat 0 }
main = do
input <- Input <$> getLine
code <- getContents
let result = case parse code of
Left error -> "Parsing error: " ++ error
Right program ->
let (t', _, Output out) = interpret program initial input
in out
putStr result
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.