git.iko.soy/production-haskell
on master help sign in
clean
commit72acec32bc13594a122a0ad574018dd5e409be07 authoriko <mail@iko.soy> dateWed 15 Jan 2025, 11:03 (2 years ago) parentc46af96
26 files changed+24−2004
compare with master
unifiedsplit
flake.nix+24 seminars/1/package.yaml−19 seminars/1/src/Task.hs−405 seminars/1/stack.yaml−7 seminars/1/task.cabal−44 seminars/1/test/Main.hs−10 seminars/1/test/Tests.hs−439 seminars/2/.gitignore−28 seminars/2/README.md−138 seminars/2/package.yaml−21 seminars/2/src/Task.hs−224 seminars/2/stack.yaml−7 seminars/2/task.cabal−47 seminars/2/test/Main.hs−10 seminars/2/test/Tests.hs−35 seminars/3/package.yaml−15 seminars/3/server.cabal−28 seminars/3/src/Main.hs−138 seminars/3/src/Task.hs−367 seminars/3/stack.yaml−9 seminars/3/state/BFState/checkpoints-0000000000.log seminars/3/state/BFState/checkpoints.version−1 seminars/3/state/BFState/events-0000000000.log seminars/3/state/BFState/events-0000000001.log seminars/3/state/BFState/events.version−1 shell.nix−11
flake.nixnew file+24
@@ -0,0 +1,24 @@
1+{
2+ inputs = {
3+ nixpkgs.url = "nixpkgs/nixos-unstable";
4+ flake-utils.url = "flake-utils";
5+ };
6+
7+ outputs = { self, flake-utils, nixpkgs }:
8+ let
9+ supportedSystems =
10+ [ "x86_64-linux" "x86_64-darwin" "aarch64-darwin" "aarch64-linux" ];
11+ compilerVersion = "982";
12+ in flake-utils.lib.eachSystem supportedSystems (system:
13+ let pkgs = import nixpkgs { inherit system; };
14+ in {
15+ devShells.default = pkgs.mkShell {
16+ buildInputs = with pkgs; [
17+ haskell.compiler."ghc${compilerVersion}"
18+ (pkgs.haskell-language-server.override {
19+ supportedGhcVersions = [ compilerVersion ];
20+ })
21+ ];
22+ };
23+ });
24+}
seminars/1/package.yamldeleted−19
@@ -1,19 +0,0 @@
1−name: task
2−version: 0.1.0.0
3−license: Unlicense
4−
5−dependencies:
6− - base >= 4.7 && < 5
7− - containers
8−
9−library:
10− source-dirs: src
11−
12−tests:
13− task-tests:
14− source-dirs: test
15− main: Main.hs
16− dependencies:
17− - tasty
18− - tasty-hunit
19− - task
seminars/1/src/Task.hsdeleted−405
@@ -1,405 +0,0 @@
1−{-# LANGUAGE InstanceSigs #-}
2−module Task
3− ( -- * List Monoids
4− constructFirstMonoid,
5− destructFirstMonoid,
6− FirstMonoid,
7− constructLastMonoid,
8− destructLastMonoid,
9− LastMonoid,
10−
11− -- * Todo List
12− Priority (..),
13− Completion (..),
14− TaskManager (..),
15− MyTaskManager,
16−
17− -- * Coffee
18− DebitCard (..),
19− Coffee (..),
20− CoffeeExtra (..),
21− HasPrice (..),
22− chargeCoffee,
23− PaymentMethod (..),
24− Customer (..),
25− payForCoffee,
26− applyPayment,
27− buyCoffee,
28− saveTheDiabetic,
29− calculateSugarDanger,
30− )
31−where
32−
33−import Data.Map (Map, empty, toList, insert, update, delete)
34−import Data.Monoid (Sum(..))
35−import qualified Data.Map
36−import Data.List (sortBy)
37−import Data.Maybe (catMaybes, listToMaybe, mapMaybe)
38−import Control.Applicative hiding (empty)
39−
40−-- _ _ _ __ __ _ _
41−-- | | (_)___| |_ | \/ | ___ _ __ ___ (_) __| |___
42−-- | | | / __| __| | |\/| |/ _ \| '_ \ / _ \| |/ _` / __|
43−-- | |___| \__ \ |_ | | | | (_) | | | | (_) | | (_| \__ \
44−-- |_____|_|___/\__| |_| |_|\___/|_| |_|\___/|_|\__,_|___/
45−
46−-- Write a datatype and a Monoid instance for it such that:
47−--
48−-- (destructFirstMonoid . fold . fmap constructFirstMonoid) == safeHead
49−--
50−-- (constructFirstMonoid and destructFirstMonoid would wrap and
51−-- unwrap the `FirstMonoid`)
52−--
53−-- In other words, it needs to have a monoid instance such that `fold`ing
54−-- a list of `FirstMonoid`s should return the first element
55−--
56−-- >>> (destructFirstMonoid . fold . fmap constructFirstMonoid) [1, 2, 3]
57−-- Just 1
58−--
59−-- >>> (destructFirstMonoid . fold . fmap constructFirstMonoid) []
60−-- Nothing
61−
62−data FirstMonoid a = FM (Maybe a)
63−
64−instance Semigroup (FirstMonoid a) where
65− (FM Nothing) <> x = x
66− x <> _ = x
67−
68−
69−instance Monoid (FirstMonoid a) where
70− mempty = FM Nothing
71−
72−-- Warps an `a` in a `FirstMonoid`.
73−constructFirstMonoid :: a -> FirstMonoid a
74−constructFirstMonoid = FM . Just
75−
76−-- Unwraps the `a` from a `FirstMonoid`, if there is one.
77−destructFirstMonoid :: FirstMonoid a -> Maybe a
78−destructFirstMonoid (FM x) = x
79−
80−-- Write a datatype and a Monoid instance for it such that:
81−--
82−-- (destructLastMonoid . fold . fmap constructLastMonoid) == safeLast
83−--
84−-- (constructLastMonoid and destructLastMonoid would wrap and
85−-- unwrap the `LastMonoid`)
86−--
87−-- In other words, it needs to have a monoid instance such that `fold`ing
88−-- a list of `LastMonoid`s should return the last element
89−--
90−-- >>> (destructLastMonoid . fold . fmap constructLastMonoid) [1, 2, 3]
91−-- Just 3
92−--
93−-- >>> (destructLastMonoid . fold . fmap constructLastMonoid) []
94−-- Nothing
95−data LastMonoid a = LM (Maybe a)
96−
97−instance Semigroup (LastMonoid a) where
98− x <> (LM Nothing) = x
99− _ <> x = x
100−
101−instance Monoid (LastMonoid a) where
102− mempty = LM Nothing
103−
104−-- Warps an `a` in a `LastMonoid`.
105−constructLastMonoid :: a -> LastMonoid a
106−constructLastMonoid = LM . Just
107−
108−-- Unwraps the `a` from a `LastMonoid`, if there is one.
109−destructLastMonoid :: LastMonoid a -> Maybe a
110−destructLastMonoid (LM x) = x
111−
112−-- _____ _ _ _ _
113−-- |_ _|__ __| | ___ | | (_)___| |_
114−-- | |/ _ \ / _` |/ _ \ | | | / __| __|
115−-- | | (_) | (_| | (_) | | |___| \__ \ |_
116−-- |_|\___/ \__,_|\___/ |_____|_|___/\__|
117−
118−-- Your task is to create a todo list backend, which supports adding tasks,
119−-- changing the priority of tasks, completing tasks, renaming tasks, and
120−-- displaying tasks as a list in order of descending priority.
121−
122−-- | The priority of a task.
123−data Priority = Low | Medium | High
124− deriving (Show, Eq, Ord)
125−
126−-- | The completion status of a task.
127−data Completion = Completed | NotCompleted
128− deriving (Show, Eq, Ord)
129−
130−class TaskManager t where
131− -- | Returns an empty task manager backend (it should have no tasks).
132− emptyTaskManager :: t
133−
134− -- | Gets the list of all tasks, sorted by priority in the order:
135− -- High, Medium, Low
136− --
137− -- Ordering of tasks with the same priority is not defined
138− -- (You can do whatever you want)
139− getPriorityList :: t -> [(Completion, Priority, String)]
140−
141− -- | Creates a new task with the given name and priority.
142− -- Tasks are uniquely identified by their name.
143− -- When a task is newly created its status should be 'NotCompleted'.
144− --
145− -- If there is already a task with the given name, then the
146− -- behavior is undefined. (You can do whatever you want)
147− createTask :: String -> Priority -> t -> t
148−
149− -- | Toggles a task with the given name.
150− -- If the task has the status 'Completed', then it would become 'NotCompleted'.
151− -- If the task has the status 'NotCompleted', then it would become 'Completed'.
152− --
153− -- Needless to say, toggling the same task twice should be
154− -- equivalent to not doing anything.
155− --
156− -- If there is no tasks with the given name, then it does nothing.
157− toggleTaskCompletion :: String -> t -> t
158−
159− -- | Removes the task with the given name.
160− -- If there isn't a task with the given name, then it does nothing.
161− removeTask :: String -> t -> t
162−
163− -- | Sets the priority of the task with the given name.
164− -- If there isn't a task with the given name, then it does nothing.
165− modifyPriority :: String -> Priority -> t -> t
166−
167− -- | Renames the task with the given name to have a new name.
168− -- The first argument is the old name, the second argument is the new name.
169− -- If there isn't a task with the given name, then it does nothing.
170− -- If the new name clashes with an existing task, then the
171− -- behavior is undefined. (You can do whatever you want)
172− renameTask :: String -> String -> t -> t
173−
174−-- The task manager you are creating.
175−data MyTaskManager = MTM (Map String (Completion, Priority))
176−
177−-- TODO: You have to make your 'MyTaskManager' an instance of
178−-- the 'TaskManager' typeclass.
179−instance TaskManager MyTaskManager where
180− emptyTaskManager = MTM empty
181−
182− getPriorityList (MTM mp) = sortBy(\(_, lhs, _) (_, rhs, _) -> compare rhs lhs) $ (\(name, (comp, pri)) -> (comp, pri, name)) <$> toList mp
183−
184− createTask :: String -> Priority -> MyTaskManager -> MyTaskManager
185− createTask name pri (MTM mp) = MTM $ insert name (NotCompleted, pri) mp
186−
187− toggleTaskCompletion name (MTM mp) = let
188− toggleTask (Completed, pri) = (NotCompleted, pri)
189− toggleTask (NotCompleted, pri) = (Completed, pri)
190− in
191− MTM $ update (Just . toggleTask) name mp
192−
193− removeTask name (MTM mp) = MTM $ delete name mp
194−
195− modifyPriority name newPri (MTM mp) = MTM $ update (\(comp, _) -> Just (comp, newPri)) name mp
196−
197− renameTask oldName newName (MTM mp) = let
198− mval = Data.Map.lookup oldName mp
199− mp1 = delete oldName mp
200− in
201− case mval of
202− Nothing -> MTM mp
203− Just val -> MTM $ insert newName val mp1
204−-- ____ __ __
205−-- / ___|___ / _|/ _| ___ ___
206−-- | | / _ \| |_| |_ / _ \/ _ \
207−-- | |__| (_) | _| _| __/ __/
208−-- \____\___/|_| |_| \___|\___|
209−--
210−-- /~~~~~~~~~~~~~~~~~~~/|
211−-- / /######/ / |
212−-- / /______/ / |
213−-- ========================= /||
214−-- |_______________________|/ ||
215−-- | \****/ \__,,__/ ||
216−-- |===\**/ __,,__ ||
217−-- |______________\====/%____||
218−-- | ___ /~~~~\ % / |
219−-- _| |===|=== / \%_/ |
220−-- | | |###| |########| | /
221−-- |____\###/______\######/__|/
222−-- ~~~~~~~~~~~~~~~~~~~~~~~~~~
223−
224−-- | Just a typealias to make types more readable.
225−type RUBAmount = Integer
226−
227−-- | Represents a cup of coffee with extra ingredients added.
228−data Coffee
229− = Coffee
230− { -- | The price of the coffee itself
231− -- (without the cost of the extra ingredients.)
232− cost :: RUBAmount,
233− -- | The extra ingredients added to the coffee.
234− extras :: [CoffeeExtra]
235− }
236− deriving (Eq, Show)
237−
238−-- Extra ingredients added to the coffee.
239−data CoffeeExtra
240− = Cream
241− | AlmondMilk
242− | SoyMilk
243− | OatMilk
244− | Cinnamon
245− | WhiteSugar
246− | BrownSugar
247− deriving (Eq, Show)
248−
249−-- | A typeclass representing objects, for which the price can be calculated.
250−class HasPrice x where
251− -- | Calculated the price of the item.
252− price :: x -> RUBAmount
253−
254−-- I have already made a 'CoffeeExtra' an instance of 'HasPrice' for you.
255−-- You should use this in price calculations.
256−instance HasPrice CoffeeExtra where
257− price Cream = 50
258− price AlmondMilk = 70
259− price SoyMilk = 80
260− price OatMilk = 65
261− price Cinnamon = 20
262− price WhiteSugar = 15
263− price BrownSugar = 35
264−
265−-- TODO: You want to make 'Coffee' an instance of 'HasPrice'.
266−instance HasPrice Coffee where
267− price x = (cost x) + getSum (foldMap (Sum . price) (extras x))
268−
269−-- | A debit card.
270−-- Note: the balance can be negative.
271−data DebitCard
272− = DebitCard
273− { balance :: RUBAmount,
274− cardId :: Int
275− }
276− deriving (Eq, Show)
277−
278−-- | Given a coffee and a debit card, deduce the total price of the coffee from
279−-- the debit card. Return the given debit card with the reduced balance.
280−--
281−-- If the balance of the debit card after deducing the price of the coffee
282−-- would become negative, return 'Nothing' from the function.
283−chargeCoffee :: Coffee -> DebitCard -> Maybe DebitCard
284−chargeCoffee coffee card
285− | price coffee <= balance card = Just card {balance=balance card - price coffee}
286− | otherwise = Nothing
287−
288−-- | How was the coffee charged.
289−data PaymentMethod
290− = -- | The coffee was charged using a debit card.
291− Card
292− { -- | The debit card with the balance deduced.
293− chargedCard :: DebitCard
294− }
295− | -- | The coffee was charged with cash.
296− Cash
297− { -- | The leftover money from the payment.
298− -- (We assume that the person pays with all of the cash he has.)
299− change :: RUBAmount
300− }
301− deriving (Eq, Show)
302−
303−-- | Represents a coffee shop customer with all of the money he has on him.
304−data Customer
305− = Customer
306− { -- | All of the debit hards the person has on him.
307− -- Sorted in order of descending preference.
308− -- (He would prefer to use the first card in the list.)
309− cards :: [DebitCard],
310− -- | The amount of cash the customer has on him.
311− cash :: RUBAmount
312− }
313− deriving (Eq, Show)
314−
315−-- You have some new privacy-invading piece of ... technology, which
316−-- automatically scans the customer, determines how he would prefer to pay and
317−-- charges him automatically.
318−
319−-- | This function determines how the given customer would prefer to pay for the
320−-- coffee he wants.
321−--
322−-- The customer would always prefer to pay with a debit card if it is possible.
323−-- The customer has a strict preference in the cards he carries with him:
324−-- he would always like to pay with the first card in his wallet (the list). If
325−-- the first card doesn't have enough money on it, then he would prefer to use
326−-- the second card, and so on.
327−--
328−-- If non of the cards have enough balance to cover the coffee, then the
329−-- customer will have to pay in cash.
330−--
331−-- NOTE: The customer can only buy a coffee with strictly one payment method.
332−-- (Only one card or cash)
333−payForCoffee :: Customer -> Coffee -> Maybe PaymentMethod
334−payForCoffee customer coffee =
335− let checkCard = chargeCoffee coffee
336− goodCards :: Maybe PaymentMethod
337− goodCards = fmap Card $ listToMaybe $ mapMaybe checkCard (cards customer)
338− cashOption = if cash customer >= price coffee then
339− Just $ Cash (cash customer - price coffee)
340− else
341− Nothing
342− in goodCards <|> cashOption
343−
344−-- | This function should apply the chosen payment method to the customer.
345−-- In other words, it needs to apply the charge to the customer himself
346−-- (update the debit card or update the amount of cash he currently has)
347−--
348−-- If the specified card is not present in the 'Customer' structure, then
349−-- do nothing.
350−--
351−-- NOTE: You can not change the order of the cards.
352−applyPayment :: Customer -> PaymentMethod -> Customer
353−applyPayment customer paymentMethod =
354− case paymentMethod of
355− Cash change -> customer {cash = change }
356− Card chargedCard ->
357− let newCards = fmap (\card -> if cardId card == cardId chargedCard then chargedCard else card ) $ cards customer
358− in customer {cards = newCards}
359−
360−
361−-- | Performs the full payment (as in 'payForCoffee') and
362−-- returns the modified customer (as in 'applyPayment').
363−buyCoffee :: Customer -> Coffee -> Maybe Customer
364−buyCoffee customer coffe =
365− let maybePaymentMethod = payForCoffee customer coffe in
366− fmap (applyPayment customer) maybePaymentMethod
367−
368−
369−-- | You know that due to a medical condition the customer needs to watch his
370−-- sugar intake. The new privacy-invading piece of ... technology can now
371−-- automatically apply filters to coffee orders.
372−--
373−-- You have to make a filter, which removes any occurrences of sugar
374−-- (either WhiteSugar or BrownSugar) from the ordered cups of coffee and
375−-- return the filtered orders and the amount of money the customer saves by
376−-- being healthy (sugar costs money after all). So, you also have to count how
377−-- much the total sugar would have cost.
378−--
379−-- NOTE: You can not change the order of the coffee.
380−saveTheDiabetic :: [Coffee] -> (RUBAmount, [Coffee])
381−saveTheDiabetic coffeeList =
382− let isSugar = (`elem` [WhiteSugar, BrownSugar])
383− sugarPrice extra = if isSugar extra then price extra else 0
384− savedMonney = foldl (\savedMonney coffee -> savedMonney + (sum $ fmap sugarPrice $ extras coffee))
385− 0 coffeeList
386− coffeesWithoutSugar = fmap (\coffee -> coffee {extras = filter (not . isSugar) $ extras coffee} ) coffeeList
387− in (savedMonney, coffeesWithoutSugar)
388−
389−
390−-- | And just to torment those who love sugar lets make a function which
391−-- calculates health hazard (sugar content) of the given orders.
392−--
393−-- The only ingredient that elevates the danger level is, of course, sugar:
394−--
395−-- WhiteSugar: 2 extra danger points
396−-- BrownSugar: 1 extra danger point
397−calculateSugarDanger :: [Coffee] -> Int
398−calculateSugarDanger coffeeList = sum $ fmap (
399− \extra -> case extra of
400− WhiteSugar -> 2
401− BrownSugar -> 1
402− _ -> 0) (coffeeList >>= extras)
403−
404−-- (>>=) :: m a -> (a -> m b) -> m b
405−-- (>>=) :: [a] -> (a -> [b]) -> [b]
seminars/1/stack.yamldeleted−7
@@ -1,7 +0,0 @@
1−resolver: lts-22.6
2−
3−packages:
4−- .
5−
6−ghc-options:
7− "$locals": -ddump-to-file -ddump-hi -fwarn-unused-binds -fwarn-unused-imports -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Werror=missing-home-modules -Wmissing-home-modules -Widentities -Wredundant-constraints -Wmissing-export-lists
seminars/1/task.cabaldeleted−44
@@ -1,44 +0,0 @@
1−cabal-version: 2.2
2−
3−-- This file has been generated from package.yaml by hpack version 0.36.0.
4−--
5−-- see: https://github.com/sol/hpack
6−--
7−-- hash: 781190f5d43564d9d73aa8b8a85a99c3d859a931a6ca644dadf871a105221b10
8−
9−name: task
10−version: 0.1.0.0
11−license: Unlicense
12−build-type: Simple
13−
14−library
15− exposed-modules:
16− Task
17− other-modules:
18− Paths_task
19− autogen-modules:
20− Paths_task
21− hs-source-dirs:
22− src
23− build-depends:
24− base >=4.7 && <5
25− , containers
26− default-language: Haskell2010
27−
28−test-suite task-tests
29− type: exitcode-stdio-1.0
30− main-is: Main.hs
31− other-modules:
32− Tests
33− Paths_task
34− autogen-modules:
35− Paths_task
36− hs-source-dirs:
37− test
38− build-depends:
39− base >=4.7 && <5
40− , containers
41− , task
42− , tasty
43− , tasty-hunit
44− default-language: Haskell2010
seminars/1/test/Main.hsdeleted−10
@@ -1,10 +0,0 @@
1−module Main
2− ( main,
3− )
4−where
5−
6−import Test.Tasty
7−import Tests
8−
9−main :: IO ()
10−main = defaultMain tests
seminars/1/test/Tests.hsdeleted−439
@@ -1,439 +0,0 @@
1−module Tests
2− ( tests,
3− )
4−where
5−
6−import Data.Foldable
7−import Data.Function
8−import Data.List
9−import Task
10−import Test.Tasty
11−import Test.Tasty.HUnit
12−
13−tests :: TestTree
14−tests = testGroup "Tests"
15− [ testGroup "List Monoids"
16− [ testCase "FirstMonoid" $ do
17− let getFirst = destructFirstMonoid . fold . fmap constructFirstMonoid
18− getFirst [1 :: Int, 2, 3] @=? Just 1
19− getFirst [] @=? (Nothing :: Maybe ())
20− getFirst [True, False] @=? Just True
21− getFirst [True, True, False] @=? Just True
22− getFirst [1 .. 1000] @=? Just (1 :: Int)
23− getFirst [100 .. 1000] @=? Just (100 :: Int)
24− getFirst [6, 2, 7, 398, 1984, 383, -1020] @=? Just (6 :: Int)
25− , testCase "LastMonoid" $ do
26− let getLast = destructLastMonoid . fold . fmap constructLastMonoid
27− getLast [1 :: Int, 2, 3] @=? Just 3
28− getLast [] @=? (Nothing :: Maybe ())
29− getLast [1 .. 1000] @=? Just (1000 :: Int)
30− getLast [100 .. 10000] @=? Just (10000 :: Int)
31− getLast [6, 2, 7, 398, 1984, 383, -1020, 498] @=? Just (498 :: Int)
32− getLast [True, False] @=? Just False
33− getLast [True, True, False] @=? Just False
34− getLast [True, True, False, True] @=? Just True
35− ]
36− , testGroup "Todo List" $
37− let createTasks :: [(String, Priority)] -> MyTaskManager
38− createTasks = foldl (\t (a, b) -> createTask a b t) emptyTaskManager
39− getPrioritySets :: MyTaskManager -> [[(Completion, String)]]
40− getPrioritySets =
41− fmap (sort . fmap (\(a, _, b) -> (a, b)))
42− . groupBy ((==) `on` (\(_, p, _) -> p))
43− . getPriorityList
44− in
45− [ testCase "emptyTaskManager" $
46− getPriorityList (emptyTaskManager :: MyTaskManager) @=? []
47− , testCase "createTask" $ do
48− getPrioritySets
49− ( createTasks
50− [ ("a", Low),
51− ("aaa", Medium),
52− ("AAAAAAAAAA", High)
53− ]
54− )
55− @=? [ [(NotCompleted, "AAAAAAAAAA")],
56− [(NotCompleted, "aaa")],
57− [(NotCompleted, "a")]
58− ]
59− getPrioritySets
60− ( createTasks
61− [ ("a", Low),
62− ("AAAAAAAAAA", High)
63− ]
64− )
65− @=? [ [(NotCompleted, "AAAAAAAAAA")],
66− [(NotCompleted, "a")]
67− ]
68− getPrioritySets
69− ( createTasks
70− [ ("a", Low),
71− ("AAAAAAAAAA", High),
72− ("aaa", Medium),
73− ("oh HaiMark", Medium)
74− ]
75− )
76− @=? [ [(NotCompleted, "AAAAAAAAAA")],
77− [(NotCompleted, "aaa"), (NotCompleted, "oh HaiMark")],
78− [(NotCompleted, "a")]
79− ]
80− getPrioritySets
81− ( createTasks
82− [ ("a", Low),
83− ("AAAAAAAAAA", High),
84− ("aaa", Medium),
85− ("oh HaiMark", Medium),
86− ("OH NO", High)
87− ]
88− )
89− @=? [ [(NotCompleted, "AAAAAAAAAA"), (NotCompleted, "OH NO")],
90− [(NotCompleted, "aaa"), (NotCompleted, "oh HaiMark")],
91− [(NotCompleted, "a")]
92− ]
93− , testCase "toggleTaskCompletion" $ do
94− getPrioritySets
95− ( toggleTaskCompletion "AAAAAAAAAA" . createTasks $
96− [ ("a", Low),
97− ("AAAAAAAAAA", High),
98− ("aaa", Medium),
99− ("oh HaiMark", Medium),
100− ("OH NO", High)
101− ]
102− )
103− @=? [ [(Completed, "AAAAAAAAAA"), (NotCompleted, "OH NO")],
104− [(NotCompleted, "aaa"), (NotCompleted, "oh HaiMark")],
105− [(NotCompleted, "a")]
106− ]
107− getPrioritySets
108− ( toggleTaskCompletion "AAAAAAAAAA" . toggleTaskCompletion "AAAAAAAAAA" . createTasks $
109− [ ("a", Low),
110− ("AAAAAAAAAA", High),
111− ("aaa", Medium),
112− ("oh HaiMark", Medium),
113− ("OH NO", High)
114− ]
115− )
116− @=? [ [(NotCompleted, "AAAAAAAAAA"), (NotCompleted, "OH NO")],
117− [(NotCompleted, "aaa"), (NotCompleted, "oh HaiMark")],
118− [(NotCompleted, "a")]
119− ]
120− getPrioritySets
121− ( toggleTaskCompletion "a"
122− . toggleTaskCompletion "not here"
123− . toggleTaskCompletion "AAAAAAAAAA"
124− . createTasks
125− $ [ ("a", Low),
126− ("AAAAAAAAAA", High),
127− ("aaa", Medium),
128− ("oh HaiMark", Medium),
129− ("OH NO", High)
130− ]
131− )
132− @=? [ [(Completed, "AAAAAAAAAA"), (NotCompleted, "OH NO")],
133− [(NotCompleted, "aaa"), (NotCompleted, "oh HaiMark")],
134− [(Completed, "a")]
135− ]
136− , testCase "removeTask" $ do
137− getPrioritySets
138− ( removeTask "AAAAAAAAAA"
139− . createTasks
140− $ [ ("a", Low),
141− ("AAAAAAAAAA", High),
142− ("aaa", Medium),
143− ("oh HaiMark", Medium),
144− ("OH NO", High)
145− ]
146− )
147− @=? [ [(NotCompleted, "OH NO")],
148− [(NotCompleted, "aaa"), (NotCompleted, "oh HaiMark")],
149− [(NotCompleted, "a")]
150− ]
151− getPrioritySets
152− ( removeTask "AAAAAAAAAA" . removeTask "AAAAAAAAAA"
153− . createTasks
154− $ [ ("a", Low),
155− ("AAAAAAAAAA", High),
156− ("aaa", Medium),
157− ("oh HaiMark", Medium),
158− ("OH NO", High)
159− ]
160− )
161− @=? [ [(NotCompleted, "OH NO")],
162− [(NotCompleted, "aaa"), (NotCompleted, "oh HaiMark")],
163− [(NotCompleted, "a")]
164− ]
165− getPrioritySets
166− ( removeTask "aaa" . removeTask "oh HaiMark"
167− . removeTask "AAAAAAAAAA"
168− . removeTask "AAAAAAAAAA"
169− . createTasks
170− $ [ ("a", Low),
171− ("AAAAAAAAAA", High),
172− ("aaa", Medium),
173− ("oh HaiMark", Medium),
174− ("OH NO", High)
175− ]
176− )
177− @=? [ [(NotCompleted, "OH NO")],
178− [(NotCompleted, "a")]
179− ]
180− , testCase "modifyPriority" $ do
181− getPrioritySets
182− ( modifyPriority "aaa" High . createTasks $
183− [ ("a", Low),
184− ("AAAAAAAAAA", High),
185− ("aaa", Medium),
186− ("oh HaiMark", Medium),
187− ("OH NO", High)
188− ]
189− )
190− @=? [ [(NotCompleted, "AAAAAAAAAA"), (NotCompleted, "OH NO"), (NotCompleted, "aaa")],
191− [(NotCompleted, "oh HaiMark")],
192− [(NotCompleted, "a")]
193− ]
194− getPrioritySets
195− ( modifyPriority "aaa" High
196− . toggleTaskCompletion "a"
197− . modifyPriority "a" High
198− . createTasks
199− $ [ ("a", Low),
200− ("AAAAAAAAAA", High),
201− ("aaa", Medium),
202− ("oh HaiMark", Medium),
203− ("OH NO", High)
204− ]
205− )
206− @=? [ [ (Completed, "a"),
207− (NotCompleted, "AAAAAAAAAA"),
208− (NotCompleted, "OH NO"),
209− (NotCompleted, "aaa")
210− ],
211− [(NotCompleted, "oh HaiMark")]
212− ]
213− getPrioritySets
214− ( modifyPriority "aaa" High
215− . modifyPriority "a" High
216− . modifyPriority "a" High
217− . modifyPriority "oh HaiMark" High
218− . createTasks
219− $ [ ("a", Low),
220− ("AAAAAAAAAA", High),
221− ("aaa", Medium),
222− ("oh HaiMark", Medium),
223− ("OH NO", High)
224− ]
225− )
226− @=? [ [ (NotCompleted, "AAAAAAAAAA"),
227− (NotCompleted, "OH NO"),
228− (NotCompleted, "a"),
229− (NotCompleted, "aaa"),
230− (NotCompleted, "oh HaiMark")
231− ]
232− ]
233− getPrioritySets
234− ( modifyPriority "aaa" High
235− . modifyPriority "a" High
236− . modifyPriority "ntestCase here sihji" High
237− . modifyPriority "oh HaiMark" Low
238− . modifyPriority "a" High
239− . modifyPriority "oh HaiMark" High
240− . createTasks
241− $ [ ("a", Low),
242− ("AAAAAAAAAA", High),
243− ("aaa", Medium),
244− ("oh HaiMark", Medium),
245− ("OH NO", High)
246− ]
247− )
248− @=? [ [ (NotCompleted, "AAAAAAAAAA"),
249− (NotCompleted, "OH NO"),
250− (NotCompleted, "a"),
251− (NotCompleted, "aaa")
252− ],
253− [(NotCompleted, "oh HaiMark")]
254− ]
255− , testCase "renameTask" $ do
256− getPrioritySets
257− ( renameTask "AAAAAAAAAA" "henlo"
258− . createTasks
259− $ [ ("a", Low),
260− ("AAAAAAAAAA", High),
261− ("aaa", Medium),
262− ("oh HaiMark", Medium),
263− ("OH NO", High)
264− ]
265− )
266− @=? [ [(NotCompleted, "OH NO"), (NotCompleted, "henlo")],
267− [(NotCompleted, "aaa"), (NotCompleted, "oh HaiMark")],
268− [(NotCompleted, "a")]
269− ]
270− getPrioritySets
271− ( renameTask "AAAAAAAAAA" "henlo"
272− . toggleTaskCompletion "a"
273− . renameTask "oh HaiMark" "iz task"
274− . createTasks
275− $ [ ("a", Low),
276− ("AAAAAAAAAA", High),
277− ("aaa", Medium),
278− ("oh HaiMark", Medium),
279− ("OH NO", High)
280− ]
281− )
282− @=? [ [(NotCompleted, "OH NO"), (NotCompleted, "henlo")],
283− [(NotCompleted, "aaa"), (NotCompleted, "iz task")],
284− [(Completed, "a")]
285− ]
286− getPrioritySets
287− ( renameTask "AAAAAAAAAA" "henlo"
288− . toggleTaskCompletion "iz task"
289− . renameTask "oh HaiMark" "iz task"
290− . renameTask "iz not here" "ajajaj"
291− . createTasks
292− $ [ ("a", Low),
293− ("AAAAAAAAAA", High),
294− ("aaa", Medium),
295− ("oh HaiMark", Medium),
296− ("OH NO", High)
297− ]
298− )
299− @=? [ [(NotCompleted, "OH NO"), (NotCompleted, "henlo")],
300− [(Completed, "iz task"), (NotCompleted, "aaa")],
301− [(NotCompleted, "a")]
302− ]
303− ]
304− , testGroup "Coffee"
305− [ testCase "HasPrice Coffee" $ do
306− price (Coffee 2 [OatMilk, Cinnamon]) @=? 2 + price OatMilk + price Cinnamon
307− price (Coffee 2 [Cinnamon, Cinnamon]) @=? 2 + price Cinnamon + price Cinnamon
308− price (Coffee 2 []) @=? 2
309− price (Coffee 2 [Cinnamon, Cream, Cinnamon])
310− @=? 2
311− + price Cinnamon
312− + price Cinnamon
313− + price Cream
314− , testCase "chargeCoffee" $ do
315− chargeCoffee (Coffee 2 [OatMilk, Cinnamon]) (DebitCard 199 69)
316− @=? Just (DebitCard 112 69)
317− chargeCoffee (Coffee 2 [OatMilk, Cinnamon]) (DebitCard 87 69)
318− @=? Just (DebitCard 0 69)
319− chargeCoffee (Coffee 2 [OatMilk, Cinnamon]) (DebitCard 86 69)
320− @=? Nothing
321− chargeCoffee (Coffee 2 [OatMilk, Cinnamon]) (DebitCard 0 69)
322− @=? Nothing
323− chargeCoffee (Coffee 2 [OatMilk, Cinnamon]) (DebitCard (-2189) 69)
324− @=? Nothing
325− chargeCoffee (Coffee 2 [OatMilk, Cinnamon, WhiteSugar]) (DebitCard 199 69)
326− @=? Just (DebitCard 97 69)
327− chargeCoffee (Coffee 2 [WhiteSugar, OatMilk, Cinnamon, WhiteSugar]) (DebitCard 199 69)
328− @=? Just (DebitCard 82 69)
329− , let coffee = Coffee 2 [OatMilk, Cinnamon]
330− in testCase "payForCoffee" $ do
331− payForCoffee (Customer [DebitCard 199 69] 0) coffee
332− @=? Just (Card (DebitCard 112 69))
333− payForCoffee (Customer [DebitCard 86 12, DebitCard 199 69] 2) coffee
334− @=? Just (Card (DebitCard 112 69))
335− payForCoffee (Customer [DebitCard (-12) 8, DebitCard 86 12, DebitCard 199 69] 0) coffee
336− @=? Just (Card (DebitCard 112 69))
337− payForCoffee (Customer [DebitCard 87 8, DebitCard 111 12, DebitCard 199 69] 0) coffee
338− @=? Just (Card (DebitCard 0 8))
339− payForCoffee (Customer [DebitCard 86 8, DebitCard 86 12, DebitCard 82 69] 0) coffee
340− @=? Nothing
341− payForCoffee (Customer [DebitCard 86 8, DebitCard 86 12, DebitCard 82 69] 87) coffee
342− @=? Just (Cash 0)
343− payForCoffee (Customer [DebitCard 86 8, DebitCard 86 12, DebitCard 81 69] 86) coffee
344− @=? Nothing
345− , testCase "applyPayment" $ do
346− applyPayment (Customer [DebitCard 199 69] 0) (Card (DebitCard 112 69))
347− @=? Customer [DebitCard 112 69] 0
348− applyPayment (Customer [DebitCard 111 12, DebitCard 199 69] 2) (Card (DebitCard 112 69))
349− @=? Customer [DebitCard 111 12, DebitCard 112 69] 2
350− applyPayment (Customer [DebitCard (-12) 8, DebitCard 111 12, DebitCard 199 69] 0) (Card (DebitCard 112 69))
351− @=? Customer [DebitCard (-12) 8, DebitCard 111 12, DebitCard 112 69] 0
352− applyPayment (Customer [DebitCard 112 8, DebitCard 111 12, DebitCard 199 69] 0) (Card (DebitCard 0 8))
353− @=? Customer [DebitCard 0 8, DebitCard 111 12, DebitCard 199 69] 0
354− applyPayment (Customer [DebitCard 111 8, DebitCard 111 12, DebitCard 110 69] 112) (Cash 0)
355− @=? Customer [DebitCard 111 8, DebitCard 111 12, DebitCard 110 69] 0
356− applyPayment (Customer [DebitCard 111 8, DebitCard 111 12, DebitCard 110 69] 112) (Card (DebitCard 0 13))
357− @=? Customer [DebitCard 111 8, DebitCard 111 12, DebitCard 110 69] 112
358− , let coffee = Coffee 2 [OatMilk, Cinnamon]
359− in testCase "buyCoffee" $ do
360− buyCoffee (Customer [DebitCard 199 69] 0) coffee
361− @=? Just (Customer [DebitCard 112 69] 0)
362− buyCoffee (Customer [DebitCard 86 12, DebitCard 199 69] 2) coffee
363− @=? Just (Customer [DebitCard 86 12, DebitCard 112 69] 2)
364− buyCoffee (Customer [DebitCard (-12) 8, DebitCard 86 12, DebitCard 199 69] 0) coffee
365− @=? Just (Customer [DebitCard (-12) 8, DebitCard 86 12, DebitCard 112 69] 0)
366− buyCoffee (Customer [DebitCard 87 8, DebitCard 86 12, DebitCard 199 69] 0) coffee
367− @=? Just (Customer [DebitCard 0 8, DebitCard 86 12, DebitCard 199 69] 0)
368− buyCoffee (Customer [DebitCard 86 8, DebitCard 86 12, DebitCard 84 69] 0) coffee
369− @=? Nothing
370− buyCoffee (Customer [DebitCard 86 8, DebitCard 86 12, DebitCard 82 69] 87) coffee
371− @=? Just (Customer [DebitCard 86 8, DebitCard 86 12, DebitCard 82 69] 0)
372− buyCoffee (Customer [DebitCard 86 8, DebitCard 86 12, DebitCard 81 69] 86) coffee
373− @=? Nothing
374− , testCase "saveTheDiabetic" $ do
375− saveTheDiabetic
376− [ Coffee 0 [WhiteSugar, BrownSugar, Cinnamon],
377− Coffee 0 [WhiteSugar, BrownSugar, Cinnamon],
378− Coffee 0 [WhiteSugar, BrownSugar, Cinnamon]
379− ]
380− @=? ( 150,
381− [ Coffee 0 [Cinnamon],
382− Coffee 0 [Cinnamon],
383− Coffee 0 [Cinnamon]
384− ]
385− )
386− saveTheDiabetic
387− [ Coffee 0 [WhiteSugar, BrownSugar, Cinnamon, BrownSugar, SoyMilk],
388− Coffee 0 [WhiteSugar, BrownSugar, WhiteSugar, WhiteSugar, Cinnamon],
389− Coffee 0 [WhiteSugar, BrownSugar, Cinnamon]
390− ]
391− @=? ( 215,
392− [ Coffee 0 [Cinnamon, SoyMilk],
393− Coffee 0 [Cinnamon],
394− Coffee 0 [Cinnamon]
395− ]
396− )
397− saveTheDiabetic
398− [ Coffee 0 [Cinnamon, SoyMilk],
399− Coffee 0 [Cinnamon],
400− Coffee 0 [Cinnamon],
401− Coffee 69 []
402− ]
403− @=? ( 0,
404− [ Coffee 0 [Cinnamon, SoyMilk],
405− Coffee 0 [Cinnamon],
406− Coffee 0 [Cinnamon],
407− Coffee 69 []
408− ]
409− )
410− saveTheDiabetic
411− []
412− @=? ( 0,
413− []
414− )
415− , testCase "calculateSugarDanger" $ do
416− calculateSugarDanger
417− [ Coffee 0 [WhiteSugar, BrownSugar, Cinnamon],
418− Coffee 0 [WhiteSugar, BrownSugar, Cinnamon],
419− Coffee 0 [WhiteSugar, BrownSugar, Cinnamon]
420− ]
421− @=? 9
422− calculateSugarDanger
423− [ Coffee 0 [WhiteSugar, BrownSugar, Cinnamon, BrownSugar, SoyMilk],
424− Coffee 0 [WhiteSugar, BrownSugar, WhiteSugar, WhiteSugar, Cinnamon],
425− Coffee 0 [WhiteSugar, BrownSugar, Cinnamon],
426− Coffee 0 []
427− ]
428− @=? 14
429− calculateSugarDanger
430− [ Coffee 0 [Cinnamon, SoyMilk],
431− Coffee 0 [Cinnamon],
432− Coffee 0 [Cinnamon]
433− ]
434− @=? 0
435− calculateSugarDanger
436− []
437− @=? 0
438− ]
439− ]
seminars/2/.gitignoredeleted−28
@@ -1,28 +0,0 @@
1−dist
2−dist-*
3−cabal-dev
4−*.o
5−*.hi
6−*.hie
7−*.chi
8−*.chs.h
9−*.dyn_o
10−*.dyn_hi
11−.hpc
12−.hsenv
13−.cabal-sandbox/
14−cabal.sandbox.config
15−*.prof
16−*.aux
17−*.hp
18−*.eventlog
19−.stack-work/
20−cabal.project.local
21−cabal.project.local~
22−.HTF/
23−.ghc.environment.*
24−.DS_Store
25−.idea/
26−*.dump-hi
27−*.lock
28−*.iml
seminars/2/README.mddeleted−138
@@ -1,138 +0,0 @@
1−# Mathematical expression interpreter
2−
3−Your task is to:
4−1. Write monadic parsing combinators
5−2. Define a structure to represent a parsed mathematical expression in Haskell
6−3. Write a parser, which parses a string into the structure
7−4. Write an interpreter for the structure, which performs the calculation and returns the result.
8−
9−**NOTE: the parser and interpreter should be independent.**
10−
11−You will have to handle division by zero errors.
12−
13−## The basic expression
14−
15−### Formal Definition
16−
17−Note that the expressions can be nested arbitrarily deeply.
18−
19−Also note, that a number can only be an integer.
20−
21−The `/` operator is integer division truncated towards negative infinity (`div` in Haskell).
22−
23−```bnf
24−<expression> ::= <number> | <operation>
25−
26−<number> ::= "-" <digits> | <digits>
27−
28−<digits> ::= <digit> | <digit> <digits>
29−<digit> ::= "0" | "1" | "2" | "3" | "4" | "5" | "6" | "7" | "8" | "9"
30−
31−<operation> ::= "(" <spaces> <expression> <spaces> <operator> <spaces> <expression> <spaces> ")"
32−
33−<operator> ::= "+" | "-" | "*" | "/"
34−
35−<spaces> ::= "" | " " <spaces>
36−```
37−
38−### Examples
39−
40−These all represent valid expressions:
41−
42−- `((1 + 2) * 3)`
43−- `1`
44−- `(((1 + 2) *3) +(1 + 1) )`
45−
46−### Minimal required combinators
47−
48−This combinator should read and return exactly one character from the input.
49−If there are no characters to read from the input, then it should fail.
50−
51−```haskell
52−anyToken :: Parser Char
53−```
54−
55−This combinator should read and return exactly one character from the input.
56−If the character does not match the given character, then it should fail.
57−
58−```haskell
59−token :: Char -> Parser ()
60−```
61−
62−This combinator should read a string of charracters. If the string does not match the given string then fail.
63−
64−```haskell
65−tokens :: String -> Parser ()
66−```
67−
68−This character reads any number of consecutive characters, which stisfy the predicate. So this can never fail.
69−
70−```haskell
71−tokensWhile :: (Char -> Bool) -> Parser String
72−```
73−
74−This character reads any number (but at least one) of consecutive characters, which stisfy the predicate. This can only fail if the first character does not satisfy the predicate.
75−
76−```haskell
77−tokensWhile1 :: (Char -> Bool) -> Parser String
78−```
79−
80−### Simple example
81−
82−A sample parser might look something like this
83−
84−```haskell
85−number :: Parser Int
86−number = do
87− sign <- signParser
88− digits <- digitsParser
89− return (read (sign <> digits))
90−```
91−
92−### Control
93−
94−The proposed approach of handling control is using the `Alternative` typeclass.
95−
96−The instance for `[]` already provides the following behavior:
97−
98−`empty` represents a failure (no values).
99−
100−`<|>` represents parsing alternative. For example an expression can be either an operation or a number.
101−
102−## Complex expressions
103−
104−This is a slightly more complex version of expressions -- it includes conditional expressions
105−
106−This represents the new parts:
107−
108−```bnf
109−<expression> ::= <number> | <operation> | <conditional>
110−
111−<conditional> ::= "if " <spaces> <bool_expression> <spaces> " then " <spaces> <expression> <spaces> " else " <spaces> <expression>
112−
113−<bool_expression> ::= "(" <spaces> <expression> <spaces> <bool_operator> <spaces> <expression> <spaces> ")"
114−
115−<bool_operator> = "=" | "<" | ">" | "<=" | ">="
116−```
117−
118−### Examples
119−
120−These all represent valid expressions:
121−
122−- `if ( 1 = 2 ) then (2 + 4) else 2`
123−- `(((1 + 2) *3) +( if ( 1 = 2 ) then (2 + 4) else 2 + 1))`
124−
125−## Artifacts
126−
127−You should export the `calculate` function, which should parse the given string and return the computed result. If any of the steps involved fail (couldn't parse the string or there was a divide by zero error), you should return `Nothing`.
128−
129−```haskell
130−calculate :: String -> Maybe Int
131−```
132−
133−## Libraries you can use
134−
135−You can use these two libraries:
136−- `base`
137−- `mtl`
138−
seminars/2/package.yamldeleted−21
@@ -1,21 +0,0 @@
1−name: task
2−version: 0.1.0.0
3−license: Unlicense
4−
5−dependencies:
6− - base >= 4.7 && < 5
7− - mtl
8− - QuickCheck
9−
10−library:
11− source-dirs: src
12−
13−tests:
14− task-tests:
15− source-dirs: test
16− main: Main.hs
17− dependencies:
18− - tasty
19− - task
20− - tasty-hunit
21− - tasty-quickcheck
seminars/2/src/Task.hsdeleted−224
@@ -1,224 +0,0 @@
1−{-# LANGUAGE DeriveFunctor #-}
2−{-# LANGUAGE InstanceSigs #-}
3−{-# LANGUAGE ScopedTypeVariables #-}
4−
5−module Task
6− ( calculate,
7− Expr(..),
8− parseFull,
9− runParser,
10− )
11−where
12−
13−import Control.Applicative
14−import Control.Monad.State.Lazy
15−import Data.Char
16−import Data.Maybe
17−import Test.QuickCheck
18−import Text.Read
19−import Debug.Trace
20−import Control.Monad
21−
22−type ParsingResult a = Either String (a, String)
23−
24−-- Parser :: Type -> Type
25−newtype Parser a = Parser (String -> ParsingResult a)
26− deriving Functor
27−
28−instance Applicative Parser where
29− pure :: a -> Parser a
30− pure x = Parser (\q -> Right (x, q))
31−
32− (<*>) :: Parser (a -> b) -> Parser a -> Parser b
33− (<*>)
34− (Parser (e :: String -> ParsingResult (a -> b)))
35− (Parser (x :: String -> ParsingResult a)) = Parser (\s ->
36− case e s of
37− Left err -> Left err
38− Right (arr, sLeft) -> case x sLeft of
39− Left err2 -> Left err2
40− Right (resOfTypeA, sLeft2) -> Right (arr resOfTypeA, sLeft2))
41−
42−instance Monad Parser where
43− return :: a -> Parser a
44− return = pure
45−
46− (>>=) :: Parser a -> (a -> Parser b) -> Parser b
47− (>>=) (Parser x) e = Parser (\s ->
48− case x s of
49− Left err -> Left err
50− Right (a, s1) -> case e a of
51− Parser f -> f s1
52− )
53−
54−instance MonadFail Parser where
55− fail :: String -> Parser a
56− fail err = Parser . const . Left $ err
57−
58−instance Alternative Parser where
59− empty :: Parser a
60− empty = Parser . const . Left $ "I'm empty"
61−
62− (Parser left) <|> (Parser right) = Parser $ \s -> case (left s, right s) of
63− (Right res, _) -> Right res
64− (Left _, Right res) -> Right res
65− (Left err1, Left err2) -> Left $ "Both alternatives failed: 1) " ++ err1 ++ "\n2:" ++ err2
66−
67−anyToken :: Parser Char
68−anyToken = Parser $ \s -> case s of
69− "" -> Left "Empty String"
70− (hd: tl) -> Right (hd, tl)
71−
72−peekToken :: Parser Char
73−peekToken = Parser $ \s -> case s of
74− "" -> Left "Empty String"
75− (hd: tl) -> Right (hd, hd : tl)
76−
77−eos :: Parser ()
78−eos = Parser $ \s -> case s of
79− "" -> Right ((), "")
80− s -> Left $ "unexpected trailing content: " ++ s
81−
82−token :: Char -> Parser ()
83−-- token expected = Parser $ \s -> case s of
84−-- "" -> Left "Empty String"
85−-- (hd: tl) -> if hd == expected then Right ((), tl) else Left $
86−token expected = do
87− actual <- anyToken
88− when (actual /= expected) $ fail $ "expected " ++ [expected] ++ ", got " ++ [actual]
89−-- when :: Applicative f => Bool -> f () -> f ()
90−
91−tokens :: String -> Parser ()
92−tokens "" = pure ()
93−tokens (c: cs) = do
94− token c
95− tokens cs
96−
97−-- "x"
98−-- u <- tokensWhile (== 'a')
99−
100−tokensWhile :: (Char -> Bool) -> Parser String
101−-- tokensWhile e = (do
102−-- char <- anyToken
103−-- str <- if e char then tokensWhile e else empty
104−-- pure (char:str)) <|> (pure "")
105−-- tokensWhile e = (do
106−-- char <- anyToken
107−-- str <- if e char then tokensWhile e else empty
108−-- pure (char:str)) <|> (pure "")
109−
110−tokensWhile e = tokensWhile1 e <|> pure ""
111−
112−tokensWhile1 :: (Char -> Bool) -> Parser String
113−tokensWhile1 e = do
114− char <- anyToken
115− -- traceShowM char
116− str <- if e char then tokensWhile e else empty
117− pure (char:str)
118−
119−-- isDigit :: Char -> Bool
120−
121−-- TODO: add negative numbers
122−number:: Parser Int
123−number = do
124− chars <- tokensWhile1 isDigit
125− case readMaybe chars of
126− Just res -> return res
127− Nothing -> fail $ "unexpected invalid number: '" ++ chars ++ "'"
128−
129−anyNumber :: Parser Int
130−anyNumber = do
131− nextChar <- peekToken
132− case nextChar of
133− '-' -> do
134− anyToken
135− number_abs <- number
136− pure $ negate number_abs
137− _ -> number
138−
139−data Expr
140− = Num Int
141− | AddExpr Expr Expr
142− | MulExpr Expr Expr
143− | SubExpr Expr Expr
144− | DivExpr Expr Expr
145− deriving (Eq)
146−
147−instance Show Expr where
148− show arg = case arg of
149− (Num i) -> show i
150− (AddExpr e1 e2) -> template "+" e1 e2
151− (MulExpr e1 e2) -> template "*" e1 e2
152− (SubExpr e1 e2) -> template "-" e1 e2
153− (DivExpr e1 e2) -> template "/" e1 e2
154− where template op e1 e2 = "(" <> show e1 <> " " <> op <> " " <> show e2 <> ")"
155−
156−half :: Gen a -> Gen a
157−half = scale (`div` 2)
158−
159−genPrimitive :: Gen Expr
160−genPrimitive = Num <$> scale ((* 5) . (+ 1)) arbitrary
161−
162−genRecursive :: Gen Expr
163−genRecursive = oneof [
164− AddExpr <$> half arbitrary <*> half arbitrary,
165− SubExpr <$> half arbitrary <*> half arbitrary,
166− MulExpr <$> half arbitrary <*> half arbitrary,
167− DivExpr <$> half arbitrary <*> half arbitrary
168− ]
169−
170−recursiveProb :: Int -> (Int, Int)
171−recursiveProb sz = (maximum [1, sz `div` 5], sz)
172−
173−instance Arbitrary Expr where
174− arbitrary = do
175− sz <- getSize
176− let (wPrim, wRec) = recursiveProb sz
177− frequency [(wPrim, genPrimitive), (wRec, genRecursive)]
178−
179−parse :: Parser Expr
180−parse = Num <$> anyNumber <|> (do
181− token '('
182− tokensWhile isSpace
183− expr1 <- parse
184− tokensWhile isSpace
185− operator <- anyToken
186− tokensWhile isSpace
187− expr2 <- parse
188− tokensWhile isSpace
189− token ')'
190− case operator of
191− '+' -> return $ AddExpr expr1 expr2
192− '*' -> return $ MulExpr expr1 expr2
193− '-' -> return $ SubExpr expr1 expr2
194− '/' -> return $ DivExpr expr1 expr2
195− _ -> fail "unknown operator"
196− )
197−
198−parseFull :: Parser Expr
199−parseFull = do
200− e <- parse
201− eos
202− return e
203−
204−evaluate :: Expr -> Maybe Int
205−evaluate (Num x) = Just x
206−evaluate (AddExpr left right) = (+) <$> (evaluate left) <*> (evaluate right)
207−evaluate (MulExpr left right) = (*) <$> (evaluate left) <*> (evaluate right)
208−evaluate (SubExpr left right) = (-) <$> (evaluate left) <*> (evaluate right)
209−evaluate (DivExpr _ right) | evaluate right == Just 0 = Nothing
210−evaluate (DivExpr left right) = div <$> (evaluate left) <*> (evaluate right)
211−
212−
213−runParser :: Parser x -> String -> Maybe x
214−runParser (Parser parser_fun) context =
215− case parser_fun context of
216− Left msg -> Nothing
217− Right (x, _) -> Just x
218−
219−
220−
221−calculate :: String -> Maybe Int
222−calculate s = do
223− expression <- runParser parseFull s
224− evaluate expression
seminars/2/stack.yamldeleted−7
@@ -1,7 +0,0 @@
1−resolver: lts-22.6
2−
3−packages:
4−- .
5−
6−ghc-options:
7− "$locals": -ddump-to-file -ddump-hi -fwarn-unused-binds -fwarn-unused-imports -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Werror=missing-home-modules -Wmissing-home-modules -Widentities -Wredundant-constraints -Wmissing-export-lists
seminars/2/task.cabaldeleted−47
@@ -1,47 +0,0 @@
1−cabal-version: 2.2
2−
3−-- This file has been generated from package.yaml by hpack version 0.36.0.
4−--
5−-- see: https://github.com/sol/hpack
6−--
7−-- hash: 570d0dca563c281c3678c542d3e97ca36237c1a0d42875afdb6b78c85c35b732
8−
9−name: task
10−version: 0.1.0.0
11−license: Unlicense
12−build-type: Simple
13−
14−library
15− exposed-modules:
16− Task
17− other-modules:
18− Paths_task
19− autogen-modules:
20− Paths_task
21− hs-source-dirs:
22− src
23− build-depends:
24− QuickCheck
25− , base >=4.7 && <5
26− , mtl
27− default-language: Haskell2010
28−
29−test-suite task-tests
30− type: exitcode-stdio-1.0
31− main-is: Main.hs
32− other-modules:
33− Tests
34− Paths_task
35− autogen-modules:
36− Paths_task
37− hs-source-dirs:
38− test
39− build-depends:
40− QuickCheck
41− , base >=4.7 && <5
42− , mtl
43− , task
44− , tasty
45− , tasty-hunit
46− , tasty-quickcheck
47− default-language: Haskell2010
seminars/2/test/Main.hsdeleted−10
@@ -1,10 +0,0 @@
1−module Main
2− ( main,
3− )
4−where
5−
6−import Test.Tasty
7−import Tests
8−
9−main :: IO ()
10−main = defaultMain tests
seminars/2/test/Tests.hsdeleted−35
@@ -1,35 +0,0 @@
1−module Tests
2− ( tests,
3− )
4−where
5−
6−import Task
7−import Test.Tasty
8−import Test.Tasty.HUnit
9−import Test.Tasty.QuickCheck
10−
11−
12−
13−tests :: TestTree
14−tests = testGroup "Tests"
15− [ testCase "Basic expression" $ do
16− calculate "((1 + 2) * 3)" @=? Just 9
17− calculate "1" @=? Just 1
18− calculate "(((1 + 2) *3) +(1 + 1) )" @=? Just 11
19− calculate "(((1 + 2) *3) +(1 + 1) " @=? Nothing
20− calculate "1 + " @=? Nothing
21− calculate "(1 / (8 - 8))" @=? Nothing
22− calculate "(4 / 2)" @=? Just 2
23− , testCase "Complex expression" $ do
24− calculate "if ( 1 = 2 ) then (2 + 4) else 2" @=? Just 2
25− calculate "(((1 + 2) *3) +( if ( 1 = 2 ) then (2 + 4) else 2 + 1) )" @=? Just 12
26− calculate "(((1 + 2) *3) +( if 1 = 2 ) then (2 + 4) else 2 + 1) )" @=? Nothing
27− calculate "(((1 + 2) *3) +( if ( 1 = 2 ) then (2 + 4) else 2 + 1)" @=? Nothing
28− calculate "(((1 + 2) *3) +( f ( 1 = 2 ) then (2 + 4) else 2 + 1) )" @=? Nothing
29− calculate "(((1 + 2) *3) +( f ( 1 = 2 ) then (2 + 4) + 1) )" @=? Nothing
30− , testProperty "parse & convert"
31− (\expr -> let expr_str = show expr
32− expr_from_str = runParser parseFull expr_str in
33− Just expr == expr_from_str
34− )
35− ]
seminars/3/package.yamldeleted−15
@@ -1,15 +0,0 @@
1−name: server
2−version: 0.1.0.0
3−license: Unlicense
4−
5−dependencies:
6− - base
7− - scotty
8− - text
9− - mtl
10− - acid-state
11− - safecopy
12−
13−executable:
14− source-dirs: src
15− main: Main.hs
seminars/3/server.cabaldeleted−28
@@ -1,28 +0,0 @@
1−cabal-version: 2.2
2−
3−-- This file has been generated from package.yaml by hpack version 0.36.0.
4−--
5−-- see: https://github.com/sol/hpack
6−
7−name: server
8−version: 0.1.0.0
9−license: Unlicense
10−build-type: Simple
11−
12−executable server
13− main-is: Main.hs
14− other-modules:
15− Task
16− Paths_server
17− autogen-modules:
18− Paths_server
19− hs-source-dirs:
20− src
21− build-depends:
22− acid-state
23− , base
24− , mtl
25− , safecopy
26− , scotty
27− , text
28− default-language: Haskell2010
seminars/3/src/Main.hsdeleted−138
@@ -1,138 +0,0 @@
1−{-# LANGUAGE ScopedTypeVariables #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE TypeFamilies #-}
4−{-# LANGUAGE TemplateHaskell #-}
5−
6−module Main (main) where
7−import Data.Text.Lazy
8−import Data.Maybe
9−import Web.Scotty
10−import Task (Tape(..), shiftTapeR, shiftTapeL, emptyTape)
11−import qualified Control.Monad.State.Class as ST
12−import Control.Monad.Reader.Class
13−
14−import Data.Acid
15−import Data.SafeCopy
16−import Data.Typeable
17−import Control.Monad.IO.Class
18−
19−
20−-- TASK:
21−-- 1 endpoint per BF command
22−-- read tape
23−-- read ouput
24−-- clear state
25−
26−
27−
28−data BFState
29− = BFState
30− { -- | The data tape.
31− bfDataTape :: Tape Int,
32− -- | The output stream of the BF interpreter.
33− bfOutput :: [Int]
34− }
35− deriving (Eq, Show)
36−
37−data BFCommand
38− = -- | The `>` command.
39− ShiftRight
40− | -- | The `<` command.
41− ShiftLeft
42− | -- | The `+` command.
43− Increment
44− | -- | The `-` command.
45− Decrement
46− | -- | The `,` command.
47− ReadInput Int
48− | -- | The `.` command.
49− WriteOutput
50− deriving (Eq, Show)
51−
52−executeCommandOnTape :: BFState -> (Tape Int -> Maybe (Tape Int)) -> BFState
53−executeCommandOnTape state f =
54− let tape = bfDataTape state
55− new_tape = fromJust (f tape)
56− in state {bfDataTape = new_tape}
57−
58−executeCommandAddToCell :: Int -> BFState -> BFState
59−executeCommandAddToCell addValue state =
60− let tape = bfDataTape state
61− old_value = tapeValue tape
62− new_tape = tape {tapeValue = old_value + addValue} in
63− state {bfDataTape = new_tape}
64−
65−executeCommand :: BFCommand -> BFState -> BFState
66−executeCommand ShiftLeft state =
67− executeCommandOnTape state shiftTapeL
68−executeCommand ShiftRight state =
69− executeCommandOnTape state shiftTapeR
70−
71−executeCommand Increment state = executeCommandAddToCell 1 state
72−executeCommand Decrement state = executeCommandAddToCell (-1) state
73−
74−executeCommand (ReadInput new_value) state =
75− let tape = bfDataTape state
76− new_tape = tape {tapeValue = new_value} in
77− state {bfDataTape = new_tape}
78−
79−executeCommand WriteOutput state =
80− let tape = bfDataTape state
81− old_output = bfOutput state
82− value = tapeValue tape
83− in state {bfOutput = value : old_output}
84−
85−-------------- acid state boilerplateexecuteCommand
86−
87−$(deriveSafeCopy 0 'base ''Tape)
88−$(deriveSafeCopy 0 'base ''BFState)
89−$(deriveSafeCopy 0 'base ''BFCommand)
90−
91−------------- add transactions
92−updateStateByExecutingCommand :: BFCommand -> Update BFState ()
93−updateStateByExecutingCommand command = do
94− currentState <- ST.get
95− -- let newState =
96− ST.put $ executeCommand command currentState
97−
98−resetState :: Update BFState ()
99−resetState = do
100− ST.put BFState {
101− bfDataTape = emptyTape,
102− bfOutput = []
103− }
104−
105−queryTape :: Query BFState (Tape Int)
106−queryTape = bfDataTape <$> ask
107−
108−queryOutput :: Query BFState [Int]
109−queryOutput = bfOutput <$> ask
110−
111−--queryState :: Query HelloWorldState String
112−--queryState = do HelloWorldState string <- ask
113−-- return string
114−
115−$(makeAcidic ''BFState ['updateStateByExecutingCommand, 'resetState, 'queryTape, 'queryOutput])
116−
117−
118−------------------------------
119−
120−main :: IO ()
121−main = do
122− acidstate <- openLocalState (BFState {bfDataTape = emptyTape, bfOutput = []})
123− scotty 3000 $ do
124− -- /add/8/12 -> 20
125− get "/tape" $ do
126− tape <- liftIO $ query acidstate QueryTape
127− text $ pack . show $ tape
128− post "/increment" $ do
129− liftIO $ update acidstate (UpdateStateByExecutingCommand Increment)
130− get "/add/:first/:second" $ do
131− first <- captureParam "first"
132− second <- captureParam "second"
133− let result:: Integer = first + second
134− text $ pack . show $ result
135− get "/:word" $ do
136− beam <- captureParam "word"
137− text beam
138−
seminars/3/src/Task.hsdeleted−367
@@ -1,367 +0,0 @@
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−-- }
seminars/3/stack.yamldeleted−9
@@ -1,9 +0,0 @@
1−resolver: lts-22.6
2−packages:
3−- .
4−
5−nix:
6− enable: true
7− packages:
8− - libffi
9− - zlib
seminars/3/state/BFState/checkpoints-0000000000.logdeleted

No changes to the content.

seminars/3/state/BFState/checkpoints.versiondeleted−1
@@ -1 +0,0 @@
1−0.16.1.3
seminars/3/state/BFState/events-0000000000.logdeleted

Binary file not shown.

seminars/3/state/BFState/events-0000000001.logdeleted

Binary file not shown.

seminars/3/state/BFState/events.versiondeleted−1
@@ -1 +0,0 @@
1−0.16.1.3
shell.nixdeleted−11
@@ -1,11 +0,0 @@
1−{ pkgs ? import <nixpkgs> { } }:
2−
3−let compilerVersion = "963";
4−in pkgs.mkShell {
5− buildInputs = with pkgs; [
6− haskell.compiler."ghc${compilerVersion}"
7− (pkgs.haskell-language-server.override {
8− supportedGhcVersions = [ compilerVersion ];
9− })
10− ];
11−}