module Control.Monad.BrainFuck where
import qualified Control.Monad as M
import qualified Data.Char as Char
newtype BrainFuck a = BrainFuck (DataPointer -> ([Char], DataPointer, a))
type DataPointer = Integer
func :: BrainFuck f -> DataPointer -> ([Char], DataPointer, f)
func (BrainFuck f) = f
brainfuck :: BrainFuck f -> String
brainfuck (BrainFuck f) = bytes where (bytes, _, _) = f 0
instance Monad BrainFuck where
return ret = BrainFuck $ \loc -> ([], loc, ret)
a >>= b = BrainFuck $ \start -> let
(left, mid, val) = func a start
(right, end, ret) = func (b val) mid
in (left ++ right, end, ret)
next, prev, incr, decr, output, input, open, close :: BrainFuck ()
next = opcode' succ '>'
prev = opcode' pred '<'
incr = opcode '+'
decr = opcode '-'
output = opcode '.'
input = opcode ','
open = opcode '['
close = opcode ']'
opcode :: Char -> BrainFuck ()
opcode = opcode' id
opcode' :: (DataPointer -> DataPointer) -> Char -> BrainFuck ()
opcode' f x = BrainFuck $ \loc -> ([x], f loc, ())
loopUnless0 :: BrainFuck a -> BrainFuck a
loopUnless0 a = do
open
r <- a
close
return r
addr :: BrainFuck DataPointer
addr = BrainFuck $ \loc -> ([], loc, loc)
setAddr :: Integer -> BrainFuck ()
setAddr n = do
a <- addr
if a > n
then prev >> setAddr n
else if a < n
then next >> setAddr n
else return ()
multi :: BrainFuck () -> Int -> BrainFuck ()
multi c n = do
_ <- sequence (replicate n c)
return ()
add, sub :: Int -> BrainFuck ()
add = multi incr
sub = multi decr
zero :: BrainFuck ()
zero = loopUnless0 decr
set :: Int -> BrainFuck ()
set n = do
zero
add n
alloc :: BrainFuck a -> BrainFuck a
alloc a = do
next
zero
cell <- addr
r <- a
setAddr cell
prev
return r
withChar :: Char.Char -> BrainFuck a -> BrainFuck a
withChar c a = alloc $ do
set (Char.ord c)
a
loopFrom :: Int -> (DataPointer -> BrainFuck ()) -> BrainFuck ()
loopFrom n a = alloc $ do
i <- addr
add n
loopUnless0 $ do
a i
setAddr i
forever :: BrainFuck a -> BrainFuck ()
forever a = loopFrom 1 $ \_ -> do
_ <- a
return ()
unless0 :: BrainFuck () -> BrainFuck ()
unless0 a = do
start <- addr
loopUnless0 $ do
a
next
zero
prev
sum :: BrainFuck ()
sum = do
next
loopUnless0 $ do
prev
incr
next
decr
prev
mult :: Int -> BrainFuck ()
mult y = do
x <- addr
alloc $ do
c1 <- addr
setAddr x
loopUnless0 $ do
setAddr c1
incr
setAddr x
decr
setAddr c1
loopUnless0 $ do
loopFrom y $ \c2 -> do
decr
setAddr x
incr
setAddr c1
decr
display :: String -> BrainFuck ()
display s = start >>= go True (map Char.ord s)
where
start = do
zero
x <- addr
add 13
mult 8
return (13 * 8)
go _ [] _ = return ()
go started (c:cs) n
| not started && delta > 13 = start >>= go True (c:cs)
| otherwise = do
if abs delta < c
then multi (if delta > 0 then incr else decr) (abs delta)
else set c
output
go False cs c
where
delta = c n
demo :: String
demo = brainfuck $ forever $ do
alloc $ do
c <- addr
set start
loopFrom numchars $ \i -> do
decr
setAddr c
output
incr
withChar ' ' output
where
start = Char.ord 'a'
end = Char.ord 'z'
numchars = end start + 1
cat :: String
cat = brainfuck $ forever $ input >> output
helloworld :: String
helloworld = brainfuck $
M.forM_ "hello, world!" $
flip withChar output
helloworld' :: String
helloworld' = optimize $ brainfuck $ display "hello, world!"
optimize :: String -> String
optimize s = go s [] s
where
go orig r [] =
let new = reverse r in
if new /= orig
then go new [] new
else new
go orig r ('>':'<':l) = go orig r l
go orig r ('<':'>':l) = go orig r l
go orig r ('+':'-':l) = go orig r l
go orig r ('-':'+':l) = go orig r l
go orig r ('[':']':l) = go orig r l
go orig [] ('[':'-':']':l) = go orig [] l
go orig [] ('>':'[':'-':']':l) = go orig [] l
go orig r (c:l) = go orig (c:r) l