@@ -0,0 +1,367 @@
1+module Task
2+ ( Tape (..),
3+ touchTape,
4+ initializeTape,
5+ emptyTape,
6+ shiftTapeL,
7+ shiftTapeR,
8+ ErrorState (..),
9+ executeErrorState,
10+ runErrorState,
11+ get,
12+ put,
13+ throwError,
14+ modify,
15+ BFState (..),
16+ BFError (..),
17+ BFMonad,
18+ readInput,
19+ writeOutput,
20+ shiftDataR,
21+ shiftDataL,
22+ readData,
23+ writeData,
24+ BFCommand (..),
25+ executeCommand,
26+ evaluateProgram,
27+ executeProgram,
28+ )
29+where
30+
31+import Data.Char
32+import Data.List
33+import Control.Monad.Except
34+import Control.Monad.State
35+
36+-- ____ _____ _ _ _
37+-- | __ )| ___| (_)_ __ | |_ ___ _ __ _ __ _ __ ___| |_ ___ _ __
38+-- | _ \| |_ | | '_ \| __/ _ \ '__| '_ \| '__/ _ \ __/ _ \ '__|
39+-- | |_) | _| | | | | | || __/ | | |_) | | | __/ || __/ |
40+-- |____/|_| |_|_| |_|\__\___|_| | .__/|_| \___|\__\___|_|
41+-- |_|
42+
43+-- In this section you will implements an interpreter for the BF language.
44+-- If you are not familiar with it, please familiarize yourself:
45+-- https://en.wikipedia.org/wiki/Brainfuck
46+
47+-- _____
48+-- |_ _|_ _ _ __ ___
49+-- | |/ _` | '_ \/ -_)
50+-- |_|\__,_| .__/\___|
51+-- |_|
52+
53+-- | Represents a possibly infinite tape with a tape head pointing to one of the
54+-- tape value.
55+--
56+-- So, this object:
57+--
58+-- Tape
59+-- { leftTape :: [2, 6, ...],
60+-- tapeValue :: 1,
61+-- rightTape :: [5, 8, ...]
62+-- }
63+--
64+-- Would represent this tape:
65+--
66+-- ◀──┬─────┬─────┬─────┬─────┬─────┬──▶
67+-- ... │ 6 │ 2 │ 1 │ 5 │ 8 │ ...
68+-- ◀──┴─────┴─────┴─────┴─────┴─────┴──▶
69+-- ▲
70+-- │
71+data Tape a
72+ = Tape
73+ { leftTape :: [a],
74+ tapeValue :: a,
75+ rightTape :: [a]
76+ }
77+ deriving (Eq, Ord)
78+
79+-- We need a special instance to handle infinite tapes. The derived
80+-- implementation would go into an infinite loop.
81+instance Show a => Show (Tape a) where
82+ show (Tape l c right) =
83+ "["
84+ <> tapeify (reverse (take 5 l))
85+ <> " { "
86+ <> show c
87+ <> " } "
88+ <> tapeify (take 5 right)
89+ <> "]"
90+ where
91+ tapeify = mconcat . intersperse " " . fmap show
92+
93+-- | Creates a tape from a list.
94+--
95+-- Note that the tape will be empty to the left.
96+--
97+-- >>> initializeTape [1, 5, 8, ...]
98+--
99+-- ┌─────┬─────┬─────┬──▶
100+-- │ 1 │ 5 │ 8 │ ...
101+-- └─────┴─────┴─────┴──▶
102+-- ▲
103+-- │
104+initializeTape :: [a] -> Maybe (Tape a)
105+initializeTape [] = Nothing
106+initializeTape (a : aa) = Just (Tape [] a aa)
107+
108+-- | This is represents the operation of moving the tape pointer to the left.
109+shiftTapeL :: Tape a -> Maybe (Tape a)
110+shiftTapeL (Tape (l : ll) c rr) = Just (Tape ll l (c : rr))
111+shiftTapeL _ = Nothing
112+
113+-- | This is represents the operation of moving the tape pointer to the right.
114+shiftTapeR :: Tape a -> Maybe (Tape a)
115+shiftTapeR (Tape ll c (r : rr)) = Just (Tape (c : ll) r rr)
116+shiftTapeR _ = Nothing
117+
118+-- | This operation allows you to modify the cell at the tape pointer.
119+touchTape :: (a -> a) -> Tape a -> Tape a
120+touchTape f (Tape l c r) = Tape l (f c) r
121+
122+-- ___ _ _ _
123+-- / __| |_ __ _| |_ ___ _ __ ___ _ _ __ _ __| |
124+-- \__ \ _/ _` | _/ -_) | ' \/ _ \ ' \/ _` / _` |
125+-- |___/\__\__,_|\__\___| |_|_|_\___/_||_\__,_\__,_|
126+
127+-- In this section we will implement the state monad with some basic operations
128+-- it supports.
129+
130+-- | Since the standard `State` monad doesn't have error handling capabilities.
131+-- we will implement a version of `State`, which can also handle errors.
132+--
133+-- `e` is the type of the possible error
134+-- `s` is the type of the state that is carried through the monad
135+-- `a` is the value that is returned.
136+-- data ErrorState e s a
137+-- = ErrorState
138+-- {runErrorState :: s -> Either e (a, s)}
139+
140+type ErrorState e s a = ExceptT e (State s) a
141+
142+-- | Executes the state monad and returns the result without returning the
143+-- final state.
144+executeErrorState :: s -> ErrorState e s a -> Either e a
145+executeErrorState s = flip evalState s . runExceptT
146+
147+-- runErrorState :: s -> ErrorState e s a -> Either e s
148+runErrorState s = flip runState s . runExceptT
149+
150+-- ___ ___ _
151+-- | _ ) __| _ __ ___ _ _ __ _ __| |
152+-- | _ \ _| | ' \/ _ \ ' \/ _` / _` |
153+-- |___/_| |_|_|_\___/_||_\__,_\__,_|
154+
155+-- In this section we will implement the specific state we will be using and
156+-- some operations that work within it.
157+
158+-- | This represents the state of our BF interpreter.
159+data BFState
160+ = BFState
161+ { -- | The data tape.
162+ bfDataTape :: Tape Int,
163+ -- | The input stream of the BF interpreter.
164+ bfInput :: [Int],
165+ -- | The output stream of the BF interpreter.
166+ bfOutput :: [Int]
167+ }
168+ deriving (Eq, Show)
169+
170+-- | This represents the errors that can occur while executing a BF program.
171+data BFError
172+ = -- | Tried reading input, but the input stream was empty.
173+ NotEnoughInput
174+ | -- | Tried going past the end of the data tape (if it was finite).
175+ DataTapeExhausted
176+ deriving (Show, Eq)
177+
178+-- | The monad in which we will interpreting the BF commands.
179+type BFMonad a = ErrorState BFError BFState a
180+
181+-- | This operation should consume one element from the input stream
182+-- and return it.
183+--
184+-- If there is not enough input, it should throw 'NotEnoughInput' error.
185+readInput :: BFMonad Int
186+readInput = do
187+ bfst <- get
188+ case bfInput bfst of
189+ [] -> throwError NotEnoughInput
190+ (x:xs)-> do
191+ put bfst { bfInput = xs }
192+ return x
193+
194+-- | This operation should write one element to the output stream.
195+-- This should just prepend the character to the start of the string using the
196+-- `:` (cons) operator.
197+--
198+-- This will make writing O(1).
199+writeOutput :: Int -> BFMonad ()
200+writeOutput value = do
201+ bfst <- get
202+ let old_output = bfOutput bfst
203+ put bfst {bfOutput = value : old_output }
204+ return ()
205+
206+-- | This operation shifts the data pointer to the right.
207+--
208+-- NOTE: if the tape has ended, you should throw the 'DataTapeExhausted' error.
209+shiftDataR :: BFMonad ()
210+shiftDataR = shiftData shiftTapeR
211+
212+
213+shiftData :: (Tape Int -> Maybe (Tape Int)) -> BFMonad ()
214+shiftData f = do
215+ bfst <- get
216+ case f $ bfDataTape bfst of
217+ Nothing -> throwError DataTapeExhausted
218+ Just x -> put bfst {bfDataTape = x }
219+
220+
221+-- | This operation shifts the data pointer to the left.
222+--
223+-- NOTE: if the tape has ended, you should throw the 'DataTapeExhausted' error.
224+shiftDataL :: BFMonad ()
225+shiftDataL = shiftData shiftTapeL
226+
227+-- | This operation reads the element at the data pointer.
228+readData :: BFMonad Int
229+readData = do
230+ bfst <- get
231+ return (tapeValue $ bfDataTape bfst)
232+
233+-- | This operation writes the element to the current data pointer.
234+writeData :: Int -> BFMonad ()
235+writeData val = do
236+ bfst <- get
237+ put bfst {bfDataTape = touchTape (const val) $ bfDataTape bfst }
238+-- _____ _ _ _ _
239+-- |_ _| |_ ___ (_)_ _| |_ ___ _ _ _ __ _ _ ___| |_ ___ _ _
240+-- | | | ' \/ -_) | | ' \ _/ -_) '_| '_ \ '_/ -_) _/ -_) '_|
241+-- |_| |_||_\___| |_|_||_\__\___|_| | .__/_| \___|\__\___|_|
242+-- |_|
243+
244+-- | The parsed commands from the BF language.
245+--
246+-- Please have a look at this commands table:
247+-- https://en.wikipedia.org/wiki/Brainfuck#Commands
248+data BFCommand
249+ = -- | 'Loop x' is equivalent to `[x]` in BF. It is essentially a while loop.
250+ Loop [BFCommand]
251+ | -- | The `>` command.
252+ ShiftRight
253+ | -- | The `<` command.
254+ ShiftLeft
255+ | -- | The `+` command.
256+ Increment
257+ | -- | The `-` command.
258+ Decrement
259+ | -- | The `,` command.
260+ ReadInput
261+ | -- | The `.` command.
262+ WriteOutput
263+ deriving (Eq, Show)
264+
265+type BFProgram = [BFCommand]
266+
267+prependMaybe :: Maybe a -> [a] -> [a]
268+prependMaybe Nothing aa = aa
269+prependMaybe (Just x) xx = x : xx
270+
271+-- | This is just a helper function.
272+parseProgram' :: String -> (BFProgram, String)
273+parseProgram' "" = ([], "")
274+parseProgram' ('[' : rest) = (Loop innerProgram : outerProgram, s')
275+ where
276+ (innerProgram, s) = parseProgram' rest
277+ (outerProgram, s') = parseProgram' s
278+parseProgram' (']' : rest) = ([], rest)
279+parseProgram' (x : rest) = (command `prependMaybe` restProgram, s)
280+ where
281+ (restProgram, s) = parseProgram' rest
282+ command = case x of
283+ '>' -> pure ShiftRight
284+ '<' -> pure ShiftLeft
285+ '+' -> pure Increment
286+ '-' -> pure Decrement
287+ '.' -> pure WriteOutput
288+ ',' -> pure ReadInput
289+ _ -> Nothing
290+
291+-- | This function parses the given string and returns a sequence of BF
292+-- commands.
293+parseProgram :: String -> BFProgram
294+parseProgram = fst . parseProgram'
295+
296+-- | Executes one BF command.
297+--
298+-- NOTE: You will probably need to call 'evaluateProgram' somewhere in
299+-- this function.
300+executeCommand :: BFCommand -> BFMonad ()
301+executeCommand ShiftLeft = shiftDataL
302+executeCommand ShiftRight = shiftDataR
303+executeCommand Increment = do
304+ cur <- readData
305+ writeData $ cur + 1
306+executeCommand Decrement = do
307+ cur <- readData
308+ writeData $ cur - 1
309+executeCommand ReadInput = readInput >>= writeData
310+executeCommand WriteOutput = readData >>= writeOutput
311+executeCommand (Loop commands) = do
312+ cur <- readData
313+ if cur == 0 then
314+ pure ()
315+ else do
316+ evaluateProgram commands
317+ executeCommand (Loop commands)
318+
319+-- | This function should evaluate the whole program.
320+evaluateProgram :: BFProgram -> BFMonad ()
321+evaluateProgram commands = sequence_ $ executeCommand <$> commands
322+
323+-- | This constant just contains an infinite empty tape. You can use this as
324+-- the initial data tape.
325+--
326+-- NOTE: It is infinite.
327+emptyTape :: Tape Int
328+emptyTape = Tape (repeat 0) 0 (repeat 0)
329+
330+-- | In this function you should bring everything together and execute the given
331+-- list of commands.
332+--
333+-- The input stream is the second argument to the function.
334+--
335+-- The returned string should contain the output stream that the evaluation
336+-- produces.
337+--
338+-- NOTE: since the output stream of the program is written backwards, you
339+-- will need to reverse the output stream. (You can use the 'reverse' function.)
340+--
341+-- You will need to construct the initial state for the monad, evaluate the
342+-- program from the initial state, and convert the resulting value to the
343+-- appropriate type.
344+executeProgram ::
345+ -- | The text of the BF program.
346+ String ->
347+ -- | The input to pass into the program.
348+ String ->
349+ Maybe String
350+executeProgram pr_str input = let program = parseProgram pr_str
351+ mon = evaluateProgram program
352+ init_bfstate = BFState {bfDataTape=emptyTape, bfInput = ord <$> input, bfOutput = []}
353+ output_or_err = executeErrorState init_bfstate (mon *> get)
354+ in case output_or_err of
355+ Left _ -> Nothing
356+ Right output -> Just $ reverse $ chr <$> (bfOutput output)
357+
358+
359+-- data BFState
360+-- = BFState
361+-- { -- | The data tape.
362+-- bfDataTape :: Tape Int,
363+-- -- | The input stream of the BF interpreter.
364+-- bfInput :: [Int],
365+-- -- | The output stream of the BF interpreter.
366+-- bfOutput :: [Int]
367+-- }