git.iko.soy/ikoHSE/sc-task-3
on master help sign in
Rewrote everything yet again 🥳
commit69d6cab4185acabee33448933173d6c61dc1590e authoriko <ilyakooo0@gmail.com> dateFri 15 May 2020, 19:39 (6 years ago) parent4ea241c
4 files changed+486−104
compare with master
unifiedsplit
package.yaml+1 src/Task.hs+130−100 task.cabal+3−2 test/Tests.hs+352−2
package.yaml+1
@@ -16,3 +16,4 @@ tests:
1616 - tasty
1717 - tasty-hspec
1818 - task
19+ - QuickCheck
src/Task.hs+130−100
@@ -1,5 +1,11 @@
11module Task
2− ( ErrorState (..),
2+ ( Tape (..),
3+ touchTape,
4+ initializeTape,
5+ shiftTapeL,
6+ shiftTapeR,
7+ ErrorState (..),
8+ executeErrorState,
39 get,
410 put,
511 throwError,
@@ -9,14 +15,11 @@ module Task
915 BFMonad,
1016 readInput,
1117 writeOutput,
12− CommandResult (..),
13− shiftCommandR,
14− shiftCommandL,
1518 shiftDataR,
1619 shiftDataL,
1720 readData,
1821 writeData,
19− readCommand,
22+ BFCommand (..),
2023 executeCommand,
2124 evaluateProgram,
2225 executeProgram,
@@ -24,6 +27,7 @@ module Task
2427where
2528
2629import Data.Char
30+import Data.List
2731
2832-- ____ _____ _ _ _
2933-- | __ )| ___| (_)_ __ | |_ ___ _ __ _ __ _ __ ___| |_ ___ _ __
@@ -68,8 +72,19 @@ data Tape a
6872 }
6973 deriving (Eq, Ord)
7074
75+-- We need a special instance to handle infinite tapes. The derived
76+-- implementation would go into an infinite loop.
7177instance Show a => Show (Tape a) where
72− show (Tape l c right) = show (reverse (take 5 l)) <> " " <> show c <> " " <> show (take 5 right)
78+ show (Tape l c right) =
79+ "["
80+ <> tapeify (reverse (take 5 l))
81+ <> " { "
82+ <> show c
83+ <> " } "
84+ <> tapeify (take 5 right)
85+ <> "]"
86+ where
87+ tapeify = mconcat . intersperse " " . fmap show
7388
7489-- | Creates a tape from a list.
7590--
@@ -77,11 +92,11 @@ instance Show a => Show (Tape a) where
7792--
7893-- >>> initializeTape [1, 5, 8, ...]
7994--
80−-- ◀──┬─────┬─────┬─────┬─────┬──▶
81−-- ... │ │ 1 │ 5 │ 8 │ ...
82−-- ◀──┴─────┴─────┴─────┴─────┴──▶
83−-- ▲
84−-- │
95+-- ┌─────┬─────┬─────┬──▶
96+-- │ 1 │ 5 │ 8 │ ...
97+-- └─────┴─────┴─────┴──▶
98+-- ▲
99+-- │
85100initializeTape :: [a] -> Maybe (Tape a)
86101initializeTape [] = Nothing
87102initializeTape (a : aa) = Just (Tape [] a aa)
@@ -118,20 +133,21 @@ data ErrorState e s a
118133 = ErrorState
119134 {runErrorState :: s -> Either e (a, s)}
120135
136+-- | Executes the state monad and returns the result without returning the
137+-- final state.
138+executeErrorState :: s -> ErrorState e s a -> Either e a
139+executeErrorState = error "TODO: executeErrorState"
140+
121141instance Functor (ErrorState e s) where
122− fmap = error "TODO: Functor (ErrorState e s) - fmap"
142+ fmap = error "TODO: fmap"
123143
124144instance Applicative (ErrorState e s) where
125− pure = error "TODO: Applicative (ErrorState e s) - pure"
126−
127− -- NOTE: State from the left hand side should be passed to the right hand
128− -- side.
129− -- Conversely the state from the right hand side should be the state of the
130− -- output.
131− (<*>) = error "TODO: Applicative (ErrorState e s) - (<*>)"
145+ pure = error "TODO: pure"
146+ (<*>) = error "TODO: <*>"
132147
133148instance Monad (ErrorState e s) where
134− (>>=) = error "TODO: Monad (ErrorState e s) - >>="
149+ (>>=) = error "TODO: >>="
150+ return = error "TODO: return"
135151
136152-- | This operation returns the state that the monad currently contains.
137153get :: ErrorState e s s
@@ -158,130 +174,143 @@ modify = error "TODO: modify"
158174-- |___/_| |_|_|_\___/_||_\__,_\__,_|
159175
160176-- In this section we will implement the specific state we will be using and
161−-- some operations that operate on it within the state monad.
162−
163−type BFCommand = Char
177+-- some operations that work within it.
164178
165179-- | This represents the state of our BF interpreter.
166180data BFState
167181 = BFState
168− { -- | The command tape. It contains the a
169− -- pointer to the command being executed.
170− bfCommandTape :: Tape BFCommand,
171− -- | The data tape.
172− bfDataTape :: Tape Char,
182+ { -- | The data tape.
183+ bfDataTape :: Tape Int,
173184 -- | The input stream of the BF interpreter.
174− bfInput :: [Char],
185+ bfInput :: [Int],
175186 -- | The output stream of the BF interpreter.
176− bfOutput :: [Char]
187+ bfOutput :: [Int]
177188 }
178189 deriving (Eq, Show)
179190
191+-- | This represents the errors that can occur while executing a BF program.
180192data BFError
181− = NotEnoughInput
182− | DataTapeExhausted
193+ = -- | Tried reading input, but the input stream was empty.
194+ NotEnoughInput
195+ | -- | Tried going past the end of the data tape (if it was finite).
196+ DataTapeExhausted
183197 deriving (Show, Eq)
184198
199+-- | The monad in which we will interpreting the BF commands.
185200type BFMonad a = ErrorState BFError BFState a
186201
187−-- | This operation should consume one 'Char' from the input stream
202+-- | This operation should consume one element from the input stream
188203-- and return it.
189204--
190−-- Should throw 'NotEnoughInput' error when the input stream is empty.
191−--
192−-- HINT: From now on it would be easier to use `do`-syntax.
193−readInput :: BFMonad Char
205+-- If there is not enough input, it should throw 'NotEnoughInput' error.
206+readInput :: BFMonad Int
194207readInput = error "TODO: readInput"
195208
196−-- | This operation should write one 'Char' to the output stream.
197−-- This should just prepend the character to the start of the string using the
198−-- `:` (cons) operator.
199−writeOutput :: Char -> BFMonad ()
200−writeOutput = error "TODO: writeOutput"
201−
202−data CommandResult
203− = ExecutionTerminated
204− | ExecutionNotTerminated
205− deriving (Eq, Show)
206−
207−-- | This operations shifts the command pointer to the right.
208−--
209−-- NOTE: The execution of the program ends successfully if the command pointer
210−-- moves past the end of the command tape.
209+-- | This operation should write the element at the data tape head to the
210+-- output stream.
211211--
212−-- For this reason you should not throw an error, and instead return whether the
213−-- execution of the program should be terminated.
214−shiftCommandR :: BFMonad CommandResult
215−shiftCommandR = error "TODO: shiftCommandR"
216−
217−-- | This operations shifts the command pointer to the left.
218−--
219−-- NOTE: The execution of the program ends successfully if the command pointer
220−-- moves past the end of the command tape.
212+-- It should just prepend the character to the start of the string using the
213+-- `:` (cons) operator.
221214--
222−-- For this reason you should not throw an error, and instead return whether the
223−-- execution of the program should be terminated.
224−shiftCommandL :: BFMonad CommandResult
225−shiftCommandL = error "TODO: shiftCommandL"
215+-- This will make writing O(1).
216+writeOutput :: Int -> BFMonad ()
217+writeOutput = error "TODO: writeOutput"
226218
227−-- | This operations shifts the data pointer to the right.
219+-- | This operation shifts the data pointer to the right.
228220--
229221-- NOTE: if the tape has ended, you should throw the 'DataTapeExhausted' error.
230222shiftDataR :: BFMonad ()
231223shiftDataR = error "TODO: shiftDataR"
232224
233−-- | This operations shifts the data pointer to the left.
225+-- | This operation shifts the data pointer to the left.
234226--
235227-- NOTE: if the tape has ended, you should throw the 'DataTapeExhausted' error.
236228shiftDataL :: BFMonad ()
237229shiftDataL = error "TODO: shiftDataL"
238230
239−-- | This operation reads the 'Char' at the data pointer.
240−--
241−-- NOTE: if the input has been exhausted, you should throw the 'NotEnoughInput'
242−-- error.
243−readData :: BFMonad Char
231+-- | This operation reads the element at the data pointer.
232+readData :: BFMonad Int
244233readData = error "TODO: readData"
245234
246−-- | This operation writes the 'Char' to the current data pointer.
247−writeData :: Char -> BFMonad ()
235+-- | This operation writes the element to the current data pointer.
236+writeData :: Int -> BFMonad ()
248237writeData = error "TODO: writeData"
249238
250−readCommand :: BFMonad BFCommand
251−readCommand = error "TODO: readCommand"
252−
253239-- _____ _ _ _ _
254240-- |_ _| |_ ___ (_)_ _| |_ ___ _ _ _ __ _ _ ___| |_ ___ _ _
255241-- | | | ' \/ -_) | | ' \ _/ -_) '_| '_ \ '_/ -_) _/ -_) '_|
256242-- |_| |_||_\___| |_|_||_\__\___|_| | .__/_| \___|\__\___|_|
257243-- |_|
258244
259−-- | Executes one BF command.
260−--
261−-- The command should be read from the function argument, not the monad state.
245+-- | The parsed commands from the BF language.
262246--
263247-- Please have a look at this commands table:
264248-- https://en.wikipedia.org/wiki/Brainfuck#Commands
249+data BFCommand
250+ = -- | 'Loop x' is equivalent to `[x]` in BF. It is essentially a while loop.
251+ Loop [BFCommand]
252+ | -- | The `>` command.
253+ ShiftRight
254+ | -- | The `<` command.
255+ ShiftLeft
256+ | -- | The `+` command.
257+ Increment
258+ | -- | The `-` command.
259+ Decrement
260+ | -- | The `,` command.
261+ ReadInput
262+ | -- | The `.` command.
263+ WriteOutput
264+ deriving (Eq, Show)
265+
266+type BFProgram = [BFCommand]
267+
268+prependMaybe :: Maybe a -> [a] -> [a]
269+prependMaybe Nothing aa = aa
270+prependMaybe (Just x) xx = x : xx
271+
272+-- | This is just a helper function.
273+parseProgram' :: String -> (BFProgram, String)
274+parseProgram' "" = ([], "")
275+parseProgram' ('[' : rest) = (Loop innerProgram : outerProgram, s')
276+ where
277+ (innerProgram, s) = parseProgram' rest
278+ (outerProgram, s') = parseProgram' s
279+parseProgram' (']' : rest) = ([], rest)
280+parseProgram' (x : rest) = (command `prependMaybe` restProgram, s)
281+ where
282+ (restProgram, s) = parseProgram' rest
283+ command = case x of
284+ '>' -> pure ShiftRight
285+ '<' -> pure ShiftLeft
286+ '+' -> pure Increment
287+ '-' -> pure Decrement
288+ '.' -> pure WriteOutput
289+ ',' -> pure ReadInput
290+ _ -> Nothing
291+
292+-- | This function parses the given string and returns a sequence of BF
293+-- commands.
294+parseProgram :: String -> BFProgram
295+parseProgram = fst . parseProgram'
296+
297+-- | Executes one BF command.
265298--
266−-- Note: non-command characters are ignored.
267−executeCommand :: BFCommand -> BFMonad CommandResult
299+-- NOTE: You will probably need to call 'evaluateProgram' somewhere in
300+-- this function.
301+executeCommand :: BFCommand -> BFMonad ()
268302executeCommand = error "TODO: executeCommand"
269303
270−-- | This function should evaluate the whole program starting from the current
271−-- command pointer.
272−--
273−-- This will probably be recursive.
274−evaluateProgram :: BFMonad ()
304+-- | This function should evaluate the whole program.
305+evaluateProgram :: BFProgram -> BFMonad ()
275306evaluateProgram = error "TODO: evaluateProgram"
276307
277−-- | This constant just contains the "zero" 'Char' value for your convenience.
278−zeroChar :: Char
279−zeroChar = toEnum 0
280−
281308-- | This constant just contains an infinite empty tape. You can use this as
282309-- the initial data tape.
283−emptyTape :: Tape Char
284−emptyTape = Tape (repeat zeroChar) zeroChar (repeat zeroChar)
310+--
311+-- NOTE: It is infinite.
312+emptyTape :: Tape Int
313+emptyTape = Tape (repeat 0) 0 (repeat 0)
285314
286315-- | In this function you should bring everything together and execute the given
287316-- list of commands.
@@ -292,14 +321,15 @@ emptyTape = Tape (repeat zeroChar) zeroChar (repeat zeroChar)
292321-- produces.
293322--
294323-- NOTE: since the output stream of the program is written backwards, you
295−-- will need to reverse the output stream. (You can use the `reverse` function.)
324+-- will need to reverse the output stream. (You can use the 'reverse' function.)
296325--
297326-- You will need to construct the initial state for the monad, evaluate the
298327-- program from the initial state, and convert the resulting value to the
299328-- appropriate type.
300−--
301−-- You can use these two functions to convert between 'Char' and 'Int':
302−-- ord :: Char -> Int
303−-- chr :: Int -> Char
304−executeProgram :: [BFCommand] -> String -> Maybe String
305−executeProgram = error "TODO: executeProgram"
329+executeProgram ::
330+ -- | The text of the BF program.
331+ String ->
332+ -- | The input to pass into the program.
333+ String ->
334+ Maybe String
335+executeProgram = error "TODO: evaluateProgram"
task.cabal+3−2
@@ -4,7 +4,7 @@ cabal-version: 2.2
44--
55-- see: https://github.com/sol/hpack
66--
7−-- hash: c454617de75af64ca6c743a3a745918472bb438f8df9c2019b67700d4caaf63c
7+-- hash: debabc49523fe978dedb0aabe06763bcd345d42b2179a742ed297254159e7414
88
99name: task
1010version: 0.1.0.0
@@ -32,7 +32,8 @@ test-suite task-tests
3232 hs-source-dirs:
3333 test
3434 build-depends:
35− base >=4.7 && <5
35+ QuickCheck
36+ , base >=4.7 && <5
3637 , task
3738 , tasty
3839 , tasty-hspec
test/Tests.hs+352−2
@@ -1,11 +1,361 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
3+{-# LANGUAGE TypeApplications #-}
4+{-# OPTIONS_GHC -O0 #-}
5+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
6+{-# OPTIONS_GHC -Wno-orphans #-}
7+{-# OPTIONS_GHC -fno-enable-rewrite-rules #-}
8+
19module Tests
210 ( tests,
311 )
412where
513
14+import Control.Arrow
15+import Data.List
16+import Data.Maybe
617import Task
18+import Test.QuickCheck
719import Test.Tasty.Hspec
820
921tests :: Spec
10−tests = do
11− return ()
22+tests = parallel $ do
23+ describe "ErrorState" $ do
24+ let eqState ::
25+ (Arbitrary s, Show s, Eq e, Eq a, Eq s, Show e, Show a) =>
26+ ErrorState e s a ->
27+ ErrorState e s a ->
28+ Property
29+ eqState lhs rhs = property $ \s -> runErrorState lhs s === runErrorState rhs s
30+ describe "Functor" $ do
31+ specify "fmap id = id" $ do
32+ let testProperty ::
33+ forall e s a.
34+ (Arbitrary s, Show s, Eq e, Eq a, Eq s, Show e, Show a) =>
35+ Blind (ErrorState e s a) ->
36+ Property
37+ testProperty (Blind s) = fmap id s `eqState` s
38+ conjoin
39+ [ property $ testProperty @() @Bool @Char,
40+ property $ testProperty @Int @Char @Bool,
41+ property $ testProperty @[Int] @[Bool] @Char,
42+ property $ testProperty @String @Bool @String
43+ ]
44+ specify "fmap (g . f) = fmap g . fmap f" $ do
45+ let testProperty ::
46+ forall e s a b c.
47+ (Arbitrary s, Show s, Eq e, Eq s, Show e, Eq c, Show c) =>
48+ Blind (ErrorState e s a) ->
49+ Fun a b ->
50+ Fun b c ->
51+ Property
52+ testProperty (Blind s) f' g' = fmap (g . f) s `eqState` (fmap g . fmap f) s
53+ where
54+ f = applyFun f'
55+ g = applyFun g'
56+ conjoin
57+ [ property $ testProperty @() @Bool @Char @Int @Char,
58+ property $ testProperty @Int @Char @Bool @() @Char,
59+ property $ testProperty @[Int] @[Bool] @Char @Int @Bool,
60+ property $ testProperty @String @Bool @String @Bool @Char
61+ ]
62+ describe "Applicative" $ do
63+ specify "pure id <*> v = v" $ do
64+ let testProperty ::
65+ forall e s a.
66+ (Arbitrary s, Show s, Eq e, Eq a, Eq s, Show e, Show a) =>
67+ Blind (ErrorState e s a) ->
68+ Property
69+ testProperty (Blind s) = (pure id <*> s) `eqState` s
70+ conjoin
71+ [ property $ testProperty @() @Bool @Char,
72+ property $ testProperty @Int @Char @Bool,
73+ property $ testProperty @[Int] @[Bool] @Char,
74+ property $ testProperty @String @Bool @String
75+ ]
76+ specify "pure f <*> pure x = pure (f x)" $ do
77+ let testProperty ::
78+ forall e s a b.
79+ (Arbitrary s, Show s, Eq e, Eq s, Show e, Eq b, Show b) =>
80+ a ->
81+ Fun a b ->
82+ Property
83+ testProperty x f' = (pure f <*> pure x) `eqState` (pure (f x) :: ErrorState e s b)
84+ where
85+ f = applyFun f'
86+ conjoin
87+ [ property $ testProperty @() @Bool @Char @Int,
88+ property $ testProperty @Int @Char @Bool @(),
89+ property $ testProperty @[Int] @[Bool] @Char @Bool,
90+ property $ testProperty @String @Bool @String @Char
91+ ]
92+ describe "Monad" $ do
93+ specify "m >>= return = m" $ do
94+ let testProperty ::
95+ forall e s a.
96+ (Arbitrary s, Show s, Eq e, Eq a, Eq s, Show e, Show a) =>
97+ Blind (ErrorState e s a) ->
98+ Property
99+ testProperty (Blind s) = (s >>= return) `eqState` s
100+ conjoin
101+ [ property $ testProperty @() @Bool @Char,
102+ property $ testProperty @Int @Char @Bool,
103+ property $ testProperty @[Int] @[Bool] @Char,
104+ property $ testProperty @String @Bool @String
105+ ]
106+ specify "return a >>= f = f a" $ do
107+ let testProperty ::
108+ forall e s a b.
109+ (Arbitrary s, Show s, Eq e, Eq s, Show e, Eq b, Show b) =>
110+ a ->
111+ Blind (Fun a (ErrorState e s b)) ->
112+ Property
113+ testProperty x (Blind f') = (return x >>= f) `eqState` f x
114+ where
115+ f = applyFun f'
116+ conjoin
117+ [ property $ testProperty @() @Bool @Char @Int,
118+ property $ testProperty @Int @Char @Bool @(),
119+ property $ testProperty @[Int] @[Bool] @Char @Bool,
120+ property $ testProperty @String @Bool @String @Char
121+ ]
122+ specify "m >>= (\\x -> f x >>= g) = (m >>= f) >>= g" $ do
123+ let testProperty ::
124+ forall e s a b c.
125+ (Arbitrary s, Show s, Eq e, Eq s, Show e, Eq c, Show c) =>
126+ Blind (ErrorState e s a) ->
127+ Blind (Fun a (ErrorState e s b)) ->
128+ Blind (Fun b (ErrorState e s c)) ->
129+ Property
130+ testProperty (Blind m) (Blind f') (Blind g') = (m >>= (\x -> f x >>= g)) `eqState` ((m >>= f) >>= g)
131+ where
132+ f = applyFun f'
133+ g = applyFun g'
134+ conjoin
135+ [ property $ testProperty @() @Bool @Char @Int @Char,
136+ property $ testProperty @Int @Char @Bool @() @Char,
137+ property $ testProperty @[Int] @[Bool] @Char @Int @Bool,
138+ property $ testProperty @String @Bool @String @Bool @Char
139+ ]
140+ specify "get" $ do
141+ let testGet :: forall b. (Show b, Eq b) => b -> Property
142+ testGet s = executeErrorState s get === (Right s :: Either () b)
143+ conjoin
144+ [ property $ testGet @(),
145+ property $ testGet @Int,
146+ property $ testGet @[Int],
147+ property $ testGet @String
148+ ]
149+ specify "put" $ do
150+ let testPut :: forall b. (Show b, Eq b) => b -> b -> Property
151+ testPut s s' = runErrorState (put s') s === (Right ((), s') :: Either () ((), b))
152+ conjoin
153+ [ property $ testPut @(),
154+ property $ testPut @Int,
155+ property $ testPut @[Int],
156+ property $ testPut @String
157+ ]
158+ specify "throwError" $ do
159+ let testThrowError :: forall e. (Show e, Eq e) => e -> Property
160+ testThrowError e = runErrorState (throwError e) undefined === (Left e :: Either e ((), ()))
161+ conjoin
162+ [ property $ testThrowError @(),
163+ property $ testThrowError @Int,
164+ property $ testThrowError @[Int],
165+ property $ testThrowError @String
166+ ]
167+ specify "modify" $ do
168+ let testModify :: forall b. (Show b, Eq b) => Fun b b -> b -> Property
169+ testModify f b = runErrorState (modify $ applyFun f) b === (Right ((), applyFun f b) :: Either () ((), b))
170+ conjoin
171+ [ property $ testModify @(),
172+ property $ testModify @Int,
173+ property $ testModify @[Int],
174+ property $ testModify @String
175+ ]
176+ describe "BFMonad" $ do
177+ describe "readInput" $ do
178+ let state i =
179+ BFState
180+ { bfDataTape = undefined,
181+ bfInput = i,
182+ bfOutput = undefined
183+ }
184+ specify "non-empty" $ do
185+ let testReadInput :: NonEmptyList Int -> Property
186+ testReadInput (NonEmpty l@(x : _)) =
187+ executeErrorState (state l) readInput === Right x
188+ property testReadInput
189+ specify "empty" $ do
190+ executeErrorState (state []) readInput
191+ `shouldBe` Left NotEnoughInput
192+ specify "writeOutput" $ do
193+ let state =
194+ BFState
195+ { bfDataTape = undefined,
196+ bfInput = undefined,
197+ bfOutput = []
198+ }
199+ testWriteOutput :: [Int] -> Property
200+ testWriteOutput l =
201+ (bfOutput . snd <$> runErrorState (mapM_ writeOutput l) state) === Right (reverse l)
202+ property testWriteOutput
203+ specify "shiftDataR" $ do
204+ let state t =
205+ BFState
206+ { bfDataTape = t,
207+ bfInput = undefined,
208+ bfOutput = undefined
209+ }
210+ testShiftDataR :: Tape Int -> Property
211+ testShiftDataR t = case shiftTapeR t of
212+ Nothing -> runErrorState shiftDataR (state t) === Left DataTapeExhausted
213+ Just t' -> (bfDataTape . snd <$> runErrorState shiftDataR (state t)) === Right t'
214+ property testShiftDataR
215+ specify "shiftDataL" $ do
216+ let state t =
217+ BFState
218+ { bfDataTape = t,
219+ bfInput = undefined,
220+ bfOutput = undefined
221+ }
222+ testShiftDataL :: Tape Int -> Property
223+ testShiftDataL t = case shiftTapeL t of
224+ Nothing -> runErrorState shiftDataL (state t) === Left DataTapeExhausted
225+ Just t' -> (bfDataTape . snd <$> runErrorState shiftDataL (state t)) === Right t'
226+ property testShiftDataL
227+ specify "readData" $ do
228+ let state t =
229+ BFState
230+ { bfDataTape = t,
231+ bfInput = undefined,
232+ bfOutput = undefined
233+ }
234+ testReadData :: Tape Int -> Property
235+ testReadData t =
236+ executeErrorState (state t) readData === Right (tapeValue t)
237+ property testReadData
238+ specify "writeData" $ do
239+ let state t =
240+ BFState
241+ { bfDataTape = t,
242+ bfInput = undefined,
243+ bfOutput = undefined
244+ }
245+ testWriteData :: Tape Int -> Int -> Property
246+ testWriteData t x =
247+ (bfDataTape . snd <$> runErrorState (writeData x) (state t)) === Right t {tapeValue = x}
248+ property testWriteData
249+ describe "BF" $ do
250+ describe "executeCommand" $ do
251+ specify "ShiftRight" $ do
252+ let state t =
253+ BFState
254+ { bfDataTape = t,
255+ bfInput = undefined,
256+ bfOutput = undefined
257+ }
258+ testShiftRight :: Tape Int -> Property
259+ testShiftRight t = case shiftTapeR t of
260+ Nothing -> runErrorState (executeCommand ShiftRight) (state t) === Left DataTapeExhausted
261+ Just t' -> (bfDataTape . snd <$> runErrorState (executeCommand ShiftRight) (state t)) === Right (t')
262+ property testShiftRight
263+ specify "ShiftLeft" $ do
264+ let state t =
265+ BFState
266+ { bfDataTape = t,
267+ bfInput = undefined,
268+ bfOutput = undefined
269+ }
270+ testShiftLeft :: Tape Int -> Property
271+ testShiftLeft t = case shiftTapeL t of
272+ Nothing -> runErrorState (executeCommand ShiftLeft) (state t) === Left DataTapeExhausted
273+ Just t' -> (bfDataTape . snd <$> runErrorState (executeCommand ShiftLeft) (state t)) === Right (t')
274+ property testShiftLeft
275+ specify "Increment" $ do
276+ let state t =
277+ BFState
278+ { bfDataTape = t,
279+ bfInput = undefined,
280+ bfOutput = undefined
281+ }
282+ testProperty :: Tape Int -> Property
283+ testProperty t =
284+ (bfDataTape . snd <$> runErrorState (executeCommand Increment) (state t)) === Right (touchTape (+ 1) t)
285+ property testProperty
286+ specify "Decrement" $ do
287+ let state t =
288+ BFState
289+ { bfDataTape = t,
290+ bfInput = undefined,
291+ bfOutput = undefined
292+ }
293+ testProperty :: Tape Int -> Property
294+ testProperty t =
295+ (bfDataTape . snd <$> runErrorState (executeCommand Decrement) (state t)) === Right (touchTape pred t)
296+ property testProperty
297+ specify "WriteOutput" $ do
298+ let state t o =
299+ BFState
300+ { bfDataTape = t,
301+ bfInput = undefined,
302+ bfOutput = o
303+ }
304+ testProperty :: Tape Int -> [Int] -> Property
305+ testProperty t l =
306+ ((bfDataTape &&& bfOutput) . snd <$> runErrorState (executeCommand WriteOutput) (state t l))
307+ === Right (t, tapeValue t : l)
308+ property testProperty
309+ specify "ReadInput" $ do
310+ let state t i =
311+ BFState
312+ { bfDataTape = t,
313+ bfInput = i,
314+ bfOutput = undefined
315+ }
316+ testProperty :: Tape Int -> [Int] -> Property
317+ testProperty t l = case l of
318+ [] -> runErrorState (executeCommand ReadInput) (state t l) === Left NotEnoughInput
319+ (x : xx) -> ((bfDataTape &&& bfInput) . snd <$> runErrorState (executeCommand ReadInput) (state t l)) === Right ((t {tapeValue = x}, xx))
320+ property testProperty
321+ specify "Loop" $ do
322+ let toList t = reverse (leftTape t) <> [tapeValue t] <> rightTape t
323+ testLoop i o l =
324+ (toList . bfDataTape . snd <$> runErrorState (executeCommand (Loop l)) (state . fromJust . initializeTape $ i))
325+ `shouldBe` Right o
326+ state t =
327+ BFState
328+ { bfDataTape = t,
329+ bfInput = undefined,
330+ bfOutput = undefined
331+ }
332+ testLoop [0] [0] []
333+ testLoop [0] [0] [Loop []]
334+ testLoop [5] [0] [Loop [Decrement]]
335+ testLoop [5, 5, 1, 2, 0] [6, 6, 2, 3, 0] [Increment, ShiftRight]
336+ describe "executeProgram" $ do
337+ specify "Hello World" $ do
338+ executeProgram "++++++++[>++++[>++>+++>+++>+<<<<-]>+>+>->>+[<]<-]>>.>---.+++++++..+++.>>.<-.<.+++.------.--------.>>+.>++." "" `shouldBe` Just "Hello World!\n"
339+ specify "Bubble Sort" $ do
340+ let sort' x = executeProgram ">>>>>,[>>>,]<<<[<<<[>>>[-<<<-<+>[>]>>]<<<[<]>>[>>>+<<<-]<[>+>>>+<<<<-]<<]>>>[.[-]]>>>[>>>]<<<]" (x <> "\NUL")
341+ property . withMaxSuccess 10 $ \(l :: String) -> let l' = filter (/= '\NUL') l in sort' l' === Just (sort l')
342+ specify "wc" $ do
343+ let wc x = executeProgram ">>>+>>>>>+>>+>>+[<<],[-[-[-[-[-[-[-[-[<+>-[>+<-[>-<-[-[-[<++[<++++++>-]<[>>[-<]<[>]<-]>>[<+>-[<->[-]]]]]]]]]]]]]]]]<[-<<[-]+>]<<[>>>>>>+<<<<<<-]>[>]>>>>>>>+>[<+[>+++++++++<-[>-<-]++>[<+++++++>-[<->-]+[+>>>>>>]]<[>+<-]>[>>>>>++>[-]]+<]>[-<<<<<<]>>>>],]+<++>>>[[+++++>>>>>>]<+>+[[<++++++++>-]<.<<<<<]>>>>>>>>]" (x <> "\NUL")
344+ wc "Hello.\nThis is a thing.\nYay!" `shouldBe` Just "\t2\t6\t28\n"
345+ wc "Hello.\n This is text\nThis is a thing.\nYay!" `shouldBe` Just "\t3\t9\t42\n"
346+ wc "Hello.\n This is \n djnjd \n text\nThis is a thing.\nYay!" `shouldBe` Just "\t5\t10\t52\n"
347+ specify "Squares" $ do
348+ executeProgram "++++[>+++++<-]>[<+++++>-]+<+[>[>+>+<<-]++>>[<<+>>-]>>>[-]++>[-]+>>>+[[-]++++++>>>]<<<[[<++++++++<++>>-]+<.<[>----<-]<]<<[>>>>>[>>>[-]+++++++++<[>-<-]+++++++++>[-[<->-]+[<<<]]<[>+<-]>]<<-]<<-]" ""
349+ `shouldBe` Just (unlines . fmap (show @Int) . takeWhile (<= 10000) . fmap (\x -> x * x) $ [0 ..])
350+ specify "Insertion Sort" $ do
351+ let sort' x = executeProgram ">>+>,[<[[>>+<<-]>[<<+<[->>+[<]]>>>[>]<<-]<<<]>>[<<+>>-]<[>+<-]>[>>]<,]<<<[<+<]>[>.>]" (x <> "\NUL")
352+ property . withMaxSuccess 10 $ \(l :: String) -> let l' = filter (/= '\NUL') l in sort' l' === Just (sort l')
353+
354+instance Arbitrary a => Arbitrary (Tape a) where
355+ arbitrary = applyArbitrary3 Tape
356+
357+instance
358+ (Arbitrary e, Arbitrary a, Function s, CoArbitrary s, Arbitrary s) =>
359+ Arbitrary (ErrorState e s a)
360+ where
361+ arbitrary = ErrorState . applyFun <$> arbitrary