-
Notifications
You must be signed in to change notification settings - Fork 0
/
brainf__k.hs
58 lines (52 loc) · 2.49 KB
/
brainf__k.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
{-#language FlexibleContexts#-}
import Control.Monad.State (MonadState, execStateT, evalStateT, MonadIO, get, modify, liftIO)
import Control.Monad.Loops (whileM_)
import Data.Char (chr, isSpace)
import Data.Word (Word8)
import System.Environment (getArgs)
import Data.Either (partitionEithers)
import Zipper
import Text.ParserCombinators.ReadP hiding (get)
data Op = LEFT -- <
| RIGHT -- >
| OUTPUT -- ,
| INPUT -- .
| ADD Int -- Adds to the current memory address (+ is equivalent to Add 1, and - to Add 255)
| ZERO -- Sets current memory address to 0 (this is equivalent to "[-]" in brainfuck)
| LOOP [Op] -- Loop expressions enclosed by []
deriving (Show, Eq)
type Memory = Zipper Int
parse :: String -> [Op]
parse = fst . last . readP_to_S (many operationP) . filter (flip elem "<>,.+-[]")
where operationP = choice [ do {char '<'; return LEFT}
, do {char ','; return INPUT}
, do {char '>'; return RIGHT}
, do {char '.'; return OUTPUT}
, do {char '+'; return (ADD 1)}
, do {char '-'; return (ADD (-1))}
, do {char '['; subExpr <- many operationP; char ']'; return (LOOP subExpr)}
]
optimize :: [Op] -> [Op]
optimize [] = []
optimize (ADD n:ADD m:cs) = optimize (ADD (n+m):cs) -- concatenate adjacent additions to the current memory address
optimize (LOOP [ADD _]:cs) = ZERO : optimize cs -- eliminate loops that exist only to set current memory address to 0, typically written [-]
optimize (LOOP xs:cs) = LOOP (optimize xs) : optimize cs
optimize (c:cs) = c : optimize cs
exec :: (MonadState Memory m, MonadIO m) => Op -> m ()
exec LEFT = modify unsafeLeft
exec RIGHT = modify unsafeRight
exec (ADD n) = modify (inplace (+n))
exec ZERO = modify (replace 0)
exec OUTPUT = get >>= liftIO . putChar . chr . current
exec INPUT = liftIO getChar >>= modify . replace . fromEnum
exec (LOOP subExpr) = whileM_ (get >>= return . (/=0) . current) (mapM_ exec subExpr)
main :: IO ()
main = do
f:_ <- getArgs
bf <- readFile f
let program = optimize (parse bf)
evalStateT (mapM_ exec program) emptyMemory
return ()
where
emptyMemory :: Memory
emptyMemory = (Zipper (repeat 0) 0 (repeat 0))