BrainFuck.hs

{-# LANGUAGE EmptyDataDecls #-}

module Control.Monad.BrainFuck where

import qualified Control.Monad as M

newtype BrainFuck a = BrainFuck (DataPointer -> ([Char], DataPointer, a))

type DataPointer = Integer

-- | Retrieve the inner function
func :: BrainFuck f -> DataPointer -> ([Char], DataPointer, f)
func (BrainFuck f) = f

-- | Evaluate the monad and get a brainfuck program
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 ()
-- | move data pointer right
next = cmd' succ '>'
-- | move data pointer left
prev = cmd' pred '<'
-- | increment data
incr = cmd '+'
-- | decrement data
decr = cmd '-'
-- | output byte at data pointer
output = cmd '.'
-- | input byte, storing at data pointer
input = cmd ','
-- | if byte at data pointer is zero, jump to command after close
open = cmd '['
-- | if byte at data pointer is nonzero, jump to command after matching open
close = cmd ']'

add, sub :: Int -> BrainFuck ()
add = multi incr
sub = multi decr

-- | Adds an arbitrary character to the program.
-- Should not be used directly.
cmd :: Char -> BrainFuck ()
cmd = cmd' id

-- | Adds an arbitrary character to the program,
-- and updates the data pointer.
-- Should not be used directly.
cmd' :: (DataPointer -> DataPointer) -> Char -> BrainFuck ()
cmd' f x =  BrainFuck $ \loc -> ([x], f loc, ())

-- | Run an action multiple times.
multi :: BrainFuck () -> Int -> BrainFuck ()
multi c n = do
	_ <- sequence (replicate n c)
	return ()

-- | Gets the current address of the data pointer.
addr :: BrainFuck DataPointer
addr = BrainFuck $ \loc -> ([], loc, loc)

-- | Moves the data pointer to a specific address.
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 ()

-- | The loop is only entered if the byte at the data pointer is not zero.
--
-- On entry, the loop body is run, and then it loops when
-- the byte at the data pointer is not zero.
loopUnless0 :: BrainFuck () -> BrainFuck ()
loopUnless0 a = do
	open
	a
	close

data Constants

-- | Let's run programs with data cells 0-8 reserved to always contain
-- the numbers 0 to 8.
--
-- These constants will make brainfuck quite a bit easier to use!
brainfuckConstants :: (Constants -> BrainFuck a) -> String
brainfuckConstants a = brainfuck $ do
	M.forM_ [0..8] $ \n -> do
		add n
		next
	a (undefined :: Constants)

-- | Sets data pointer to point to one of the Constants.
at :: Constants -> Integer -> BrainFuck ()
at _ = setAddr

-- | Run an action in a loop, until it sets its data pointer to 0.
loop :: Constants -> BrainFuck () -> BrainFuck ()
loop constants a = do
	here <- addr
	at constants 1
	loopUnless0 $ do
		setAddr here
		a

-- | Runs an action in an infinite loop.
forever :: Constants -> BrainFuck () -> BrainFuck ()
forever constants a = loop constants $ do
	a
	at constants 1

-- | Prints out the ASCII table, starting with space, repeatedly.
-- 
-- TODO: Only print printable characters.
demo :: String
demo = brainfuckConstants $ \constants -> do
	add 32
	forever constants $ do
		add 1
		output