brainf

src/Main.hs

@@ -0,0 +1,78 @@
+module Main where
+
+import Data.Bifunctor (Bifunctor (first))
+import Data.Char (chr, ord)
+import qualified Data.Vector.Unboxed.Mutable as UM
+import Data.Word (Word8)
+import System.Environment (getArgs)
+import System.IO (IOMode (ReadMode), hGetContents, openFile)
+
+data Instruction
+  = IncPointer
+  | DecPointer
+  | IncByte
+  | DecByte
+  | OutByte
+  | AccByte
+  | Loop [Instruction]
+  deriving (Show)
+
+parseBf' :: String -> ([Instruction], String)
+parseBf' ('>' : rest) = first (IncPointer :) (parseBf' rest)
+parseBf' ('<' : rest) = first (DecPointer :) (parseBf' rest)
+parseBf' ('+' : rest) = first (IncByte :) (parseBf' rest)
+parseBf' ('-' : rest) = first (DecByte :) (parseBf' rest)
+parseBf' ('.' : rest) = first (OutByte :) (parseBf' rest)
+parseBf' (',' : rest) = first (AccByte :) (parseBf' rest)
+parseBf' ('[' : rest) =
+  let (parsed, next) = parseBf' rest
+   in first (Loop (parsed) :) (parseBf' next)
+parseBf' (']' : rest) = ([], rest)
+parseBf' (_ : rest) = parseBf' rest
+parseBf' [] = ([], "")
+
+parseBf :: String -> [Instruction]
+parseBf = fst . parseBf'
+
+interpret :: [Instruction] -> UM.IOVector Word8 -> Int -> IO Int
+interpret [] _ pointer = return pointer
+interpret (IncPointer : rest) tape pointer = interpret rest tape (pointer + 1)
+interpret (DecPointer : rest) tape pointer = interpret rest tape (pointer - 1)
+interpret (IncByte : rest) tape pointer = do
+  UM.modify tape (+ 1) pointer
+  interpret rest tape pointer
+interpret (DecByte : rest) tape pointer = do
+  UM.modify tape (subtract 1) pointer
+  interpret rest tape pointer
+interpret (OutByte : rest) tape pointer = do
+  UM.read tape pointer >>= putChar . chr . fromIntegral
+  interpret rest tape pointer
+interpret (AccByte : rest) tape pointer = do
+  getChar >>= (return . fromIntegral . ord) >>= UM.write tape pointer
+  interpret rest tape pointer
+interpret (Loop instructions : rest) tape pointer = do
+  pointer' <- looper pointer
+  interpret rest tape pointer'
+  where
+    looper :: Int -> IO Int
+    looper pointer' = do
+      currentByte <- UM.read tape pointer'
+      case currentByte of
+        0 -> return pointer'
+        _ -> do
+          pointer'' <- interpret instructions tape pointer'
+          looper pointer''
+
+run :: String -> IO ()
+run input = do
+  initialTape <- UM.replicate 30000 0
+  _ <- interpret (parseBf input) initialTape 0
+  return ()
+
+main :: IO ()
+main = do
+  args <- getArgs
+
+  let path = args !! 0
+
+  openFile path ReadMode >>= hGetContents >>= run