-
Notifications
You must be signed in to change notification settings - Fork 272
/
Brainfuck.hs
147 lines (113 loc) · 4.05 KB
/
Brainfuck.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
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
{-# LANGUAGE TypeOperators #-}
-----------------------------------------------------------------------------
-- |
-- Module : Brainfuck
-- Copyright : (C) 2012 Edward Kmett, nand`
-- License : BSD-style (see the file LICENSE)
-- Maintainer : Edward Kmett <ekmett@gmail.com>
-- Stability : provisional
-- Portability : TH, Rank2, NoMonomorphismRestriction
--
-- A simple interpreter for the esoteric programming language "Brainfuck"
-- written using lenses and zippers.
-----------------------------------------------------------------------------
module Main where
import Prelude hiding (Either(..))
import Control.Lens
import Control.Applicative
import Control.Monad.Free
import Control.Monad.RWS
import qualified Data.ByteString.Lazy as BS
import Data.Maybe (fromMaybe)
import qualified Data.Stream.Infinite as S
import Data.Word (Word8)
import System.Environment (getArgs)
import System.IO
-- Low level syntax form
data Instr = Plus | Minus | Right | Left | Comma | Dot | Open | Close
type Code = [Instr]
parse :: String -> Code
parse = concatMap (maybe [] return . (`lookup` symbols))
where symbols = [ ('+', Plus ), ('-', Minus), ('<', Left), ('>', Right)
, (',', Comma), ('.', Dot ), ('[', Open), (']', Close) ]
-- Higher level semantic graph
data Brainfuck n
= Succ n | Pred n -- Increment or decrement the current value
| Next n | Prev n -- Shift memory left or right
| Read n | Write n -- Input or output the current value
-- Branching semantic, used for both sides of loops
| Branch { zero :: n, nonzero :: n }
type Program = Free Brainfuck ()
compile :: Code -> Program
compile = fst . bracket []
bracket :: [Program] -> Code -> (Program, [Program])
bracket [] [] = (Pure (), [])
bracket _ [] = error "Mismatched opening bracket"
bracket [] (Close:_) = error "Mismatched closing bracket"
-- Match a closing bracket: Pop a forward continuation, push backwards
bracket (c:cs) (Close : xs) = (Free (Branch n c), n:bs)
where (n, bs) = bracket cs xs
-- Match an opening bracket: Pop a backwards continuation, push forwards
bracket cs (Open : xs) = (Free (Branch b n), bs)
where (n, b:bs) = bracket (n:cs) xs
-- Match any other symbol in the trivial way
bracket cs (x:xs) = over _1 (Free . f x) (bracket cs xs)
where
f Plus = Succ; f Minus = Pred
f Right = Next; f Left = Prev
f Comma = Read; f Dot = Write
-- * RWS-based interpreter
type Cell = Word8
type Input = S.Stream Cell
type Output = [Cell]
type Memory = Top :> [Cell] :> Cell -- list zipper
type Interpreter = RWS Input Output Memory ()
-- | Initial memory configuration
initial :: Memory
initial = zipper (replicate 30000 0) & fromWithin traverse
interpret :: Input -> Program -> Output
interpret i p = snd $ execRWS (run p) i initial
-- | Evaluation function
run :: Program -> Interpreter
run (Pure _) = return ()
run (Free f) = case f of
Succ n -> focus += 1 >> run n
Pred n -> focus -= 1 >> run n
Next n -> modify wrapRight >> run n
Prev n -> modify wrapLeft >> run n
Read n -> do
focus <~ asks S.head
local S.tail $ run n
Write n -> do
tell . return =<< use focus
run n
Branch z n -> do
c <- use focus
run $ case c of 0 -> z; _ -> n
-- | Zipper helpers
wrapRight, wrapLeft :: (a :> b) -> (a :> b)
wrapRight = liftM2 fromMaybe leftmost right
wrapLeft = liftM2 fromMaybe rightmost left
-- Main program action to actually run this stuff
main :: IO ()
main = do
as <- getArgs
case as of
-- STDIN is program
[ ] -> do
hSetBuffering stdin NoBuffering
hSetBuffering stdout NoBuffering
getContents >>= eval noInput
-- STDIN is input
[f] -> join $ eval <$> getInput <*> readFile f
-- Malformed command line
_ -> putStrLn "Usage: brainfuck [program]"
eval :: Input -> String -> IO ()
eval i = mapM_ putByte . interpret i . compile . parse
where putByte = BS.putStr . BS.pack . return
-- | EOF is represented as 0
getInput :: IO Input
getInput = f <$> BS.getContents
where f s = S.fromList (BS.unpack s ++ repeat 0)
noInput :: Input
noInput = S.repeat 0