{-# LANGUAGE DeriveFunctor #-}
module Control.Monad.BrainFuck where
import qualified Control.Monad as M
import Control.Monad (ap)
import qualified Data.Char as Char
import Data.Word (Word8)
import System.Process
import System.IO
import System.Exit
import System.Directory
newtype BrainFuck a = BrainFuck (DataPointer -> ([Char], DataPointer, a))
deriving (Functor)
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
a >>= b = BrainFuck $ \start -> let
(left, mid, val) = func a start
(right, end, ret) = func (b val) mid
in (left ++ right, end, ret)
instance Applicative BrainFuck where
pure v = BrainFuck $ \loc -> ([], loc, v)
(<*>) = ap
next, prev, incr, decr, output, input, open, close, debug :: BrainFuck ()
next = opcode' succ '>'
prev = opcode' pred '<'
incr = opcode '+'
decr = opcode '-'
output = opcode '.'
input = opcode ','
open = opcode '['
close = opcode ']'
debug = 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
start <- addr
open
r <- a
setAddr start
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 ()
withAddr :: Integer -> BrainFuck a -> BrainFuck a
withAddr n a = do
old <- addr
setAddr n
r <- a
setAddr old
return r
multi :: BrainFuck () -> Int -> BrainFuck ()
multi c n = do
_ <- sequence (replicate n c)
return ()
add, sub :: Word8 -> BrainFuck ()
add = multi incr . fromIntegral
sub = multi decr . fromIntegral
zero :: BrainFuck ()
zero = loopUnless0 decr
set :: Word8 -> 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
alloc' :: (DataPointer -> BrainFuck a) -> BrainFuck a
alloc' a = alloc $ addr >>= a
withChar :: Char.Char -> BrainFuck a -> BrainFuck a
withChar c a = alloc $ do
set $ fromIntegral $ Char.ord c
a
loopFrom :: Word8 -> (DataPointer -> BrainFuck ()) -> BrainFuck ()
loopFrom n a =
alloc' $ \i -> do
add n
loopUnless0 $
a i
forever :: BrainFuck a -> BrainFuck ()
forever a = loopFrom 1 $ \_i ->
alloc' $ \_scratch -> do
_ <- a
return ()
copy :: DataPointer -> DataPointer -> BrainFuck ()
copy src dest = do
withAddr dest zero
alloc' $ \tmp -> do
setAddr src
loopUnless0 $ do
decr
setAddr dest
incr
setAddr tmp
incr
setAddr tmp
loopUnless0 $ do
decr
setAddr src
incr
withNot :: DataPointer -> BrainFuck () -> BrainFuck ()
withNot p a = alloc' $ \tmp1 -> do
copy p tmp1
alloc' $ \tmp2 -> do
incr
setAddr tmp1
loopUnless0 $ do
zero
setAddr tmp2
decr
setAddr tmp2
a
unless0 :: DataPointer -> BrainFuck () -> BrainFuck ()
unless0 p a = do
start <- addr
alloc' $ \tmp -> do
copy p tmp
loopUnless0 $ do
setAddr start
a
setAddr tmp
zero
when0 :: DataPointer -> BrainFuck () -> BrainFuck ()
when0 p a = withNot p $
addr >>= flip unless0 a
if0 :: DataPointer -> (BrainFuck (), BrainFuck ()) -> BrainFuck ()
if0 p (y, n) = do
when0 p y
unless0 p n
sumNext :: BrainFuck ()
sumNext = do
next
loopUnless0 $ do
prev
incr
next
decr
prev
mult :: Word8 -> BrainFuck ()
mult y = do
x <- addr
alloc' $ \c1 -> do
setAddr x
loopUnless0 $ do
decr
setAddr c1
incr
setAddr c1
loopUnless0 $ do
decr
loopFrom y $ \_c2 -> do
decr
setAddr x
incr
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 (fromIntegral c)
output
go False cs c
where
delta = c - n
demo :: String
demo = brainfuck demo'
demo' :: BrainFuck ()
demo' = alloc' $ \tilt -> do
settilt
alloc' $ \tc -> do
decr
alloc' $ \wc -> do
copy tilt wc
forever $ alloc' $ \c -> do
set (fromIntegral start)
loopFrom (fromIntegral numchars) $ \_i -> do
decr
withAddr wc decr
when0 wc $ do
loopFrom 3 $ \_ -> do
decr
withChar ' ' output
copy tilt wc
withAddr tc decr
when0 tc $ do
withAddr tc decr
withAddr tilt decr
when0 tilt $ do
withAddr tilt
settilt
setAddr c
output
incr
where
start = Char.ord 'a'
end = Char.ord 'z'
numchars = end - start + 1
settilt = do
set 4
mult 5
cat :: String
cat = brainfuck $ forever $ alloc $ 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 = trimend $ 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 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
trimend = reverse . dropWhile (`elem` "><") . reverse
compile :: FilePath -> BrainFuck () -> IO ()
compile dest b = movfuscate b >>= nasm dest >>= ld dest
type ASM = String
movfuscate :: BrainFuck () -> IO ASM
movfuscate b = do
(Just hin, Just hout, Nothing, h) <- createProcess $
(proc "movfuscator" [])
{ std_out = CreatePipe
, std_in = CreatePipe
}
hPutStr hin $ optimize $ brainfuck b
hClose hin
asm <- hGetContents hout
writeFile "asm" asm
c <- waitForProcess h
case c of
ExitSuccess -> return ()
_ -> error ("movfuscator exited nonzero")
return asm
nasm :: FilePath -> ASM -> IO FilePath
nasm dest a = do
writeFile asmfile a
callProcess "nasm" ["-felf", asmfile, "-o", objfile]
removeFile asmfile
return objfile
where
asmfile = dest ++ ".asm"
objfile = dest ++ ".o"
ld :: FilePath -> FilePath -> IO ()
ld dest objfile = do
callProcess "ld" ["-melf_i386", objfile, "-o", dest]
removeFile objfile