78 lines
2.4 KiB
Haskell
78 lines
2.4 KiB
Haskell
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
|