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 ']'
add, sub :: Int -> BrainFuck ()
add = multi incr
sub = multi decr
opcode :: Char -> BrainFuck ()
opcode = opcode' id
opcode' :: (DataPointer -> DataPointer) -> Char -> BrainFuck ()
opcode' f x = BrainFuck $ \loc -> ([x], f loc, ())
multi :: BrainFuck () -> Int -> BrainFuck ()
multi c n = do
_ <- sequence (replicate n c)
return ()
char :: Char.Char -> BrainFuck ()
char = multi incr . Char.ord
unchar :: Char.Char -> BrainFuck ()
unchar = multi decr . Char.ord
withChar :: Char.Char -> BrainFuck a -> BrainFuck a
withChar c a = do
char c
r <- a
unchar c
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 ()
loopUnless0 :: BrainFuck () -> BrainFuck ()
loopUnless0 a = do
open
a
close
data Constants = Constants NumConstants Integer
type NumConstants = Int
brainfuckConstants :: NumConstants -> (Constants -> BrainFuck a) -> String
brainfuckConstants numconstants a = brainfuck $ do
M.forM_ [0..numconstants] $ \n -> do
add (numconstants n)
next
a (Constants numconstants 0)
pointAt :: Constants -> Integer -> BrainFuck ()
pointAt (Constants numconstants c) i = setAddr (c + fromIntegral numconstants i)
loop :: Constants -> BrainFuck () -> BrainFuck ()
loop constants a = do
here <- addr
pointAt constants 1
loopUnless0 $ do
setAddr here
a
forever :: Constants -> BrainFuck () -> BrainFuck ()
forever constants a = loop constants $ do
a
pointAt constants 1
demo :: String
demo = brainfuckConstants 1 $ \constants -> do
add $ Char.ord ' '
forever constants $ do
add 1
output
cat :: String
cat = brainfuckConstants 1 $ flip forever $ input >> output
helloworld :: String
helloworld = brainfuck $
M.forM_ "hello, world!" $
flip withChar output