brainfuck.hs

module Main
  (main
  ) where

import Text.Parsec hiding (State (..))
import Text.Parsec.String

import Control.Monad.State

import qualified Data.IntMap.Lazy as I

import Data.Word (Word8)

import System.Environment (getArgs)

type Program = [BFCommand]
data BFCommand = Move Int
               | Change Word8
               | Show
               | Read
               | Loop Program
               | Clear
               | Copy Offset Multiplier deriving Show
type Offset = Int
type Multiplier = Word8

--{ parser }--

pBF, pMove, pChange, pRead, pShow, pLoop :: Parser BFCommand

pBF = pMove
  <|> pChange
  <|> pRead
  <|> pShow
  <|> try pOptimizations
  <|> pLoop

pMove = do
  x <- many1 $ oneOf "<>"
  return $ Move $ sum $ map (\x -> if x == '>' then 1 else -1) x

pChange = do
  x <- many1 $ oneOf "+-"
  return $ Change $ sum $ map (\x -> if x == '+' then 1 else -1) x

pRead = do
  char ','
  return Read

pShow = do
  char '.'
  return Show

pLoop = do
  char '['
  x <- pProgram
  char ']'
  return $ Loop x

pProgram :: Parser Program
pProgram = many pBF

--{ optimization parsing }--

pOptimizations = pClear

pClear :: Parser BFCommand

pClear = do
  string "[-]"
  return Clear


--{ runtime }--

type BFState = StateT (Int, I.IntMap Word8) IO ()

execInstruction :: BFCommand -> BFState
execInstruction n = do
  (p, t) <- get
  case n of
    (Move m)   -> put (p+m, t)
    (Change c) -> do
      let val = I.findWithDefault 0 p t
      put (p, I.insert p (val+c) t)
    Show       -> do
      let c = I.findWithDefault 0 p t
      liftIO $ putChar (toEnum $ fromIntegral c)
    Read       -> do
      c <- liftIO getChar
      put (p, I.insert p (fromIntegral $ fromEnum c) t)
    loop@(Loop l)   -> unless (I.findWithDefault 0 p t == 0) $ do
          execProgram l
          execInstruction loop
    Clear      -> put (p, I.insert p 0 t)

execProgram = mapM_ execInstruction

runBF l = do
  let p = parse pProgram "" $ filter isBFChar l
  case p of
    (Left e) -> print e
    (Right r) -> do
      print r
      evalStateT (execProgram r) (0, I.empty)
      putStrLn ""
  where
    isBFChar = (`elem` "<>-+,.[]")

main = do
  source <- getContents
  runBF source