.

seminars/1/src/Task.hs

@@ -34,6 +34,8 @@ import Data.Map (Map, empty, toList, insert, update, delete)
 import Data.Monoid (Sum(..))
 import qualified Data.Map
 import Data.List (sortBy)
+import Data.Maybe (catMaybes, listToMaybe, mapMaybe)
+import Control.Applicative hiding (empty)
 
 --   _     _     _     __  __                   _     _
 --  | |   (_)___| |_  |  \/  | ___  _ __   ___ (_) __| |___
@@ -279,7 +281,9 @@ data DebitCard
 -- If the balance of the debit card after deducing the price of the coffee
 -- would become negative, return 'Nothing' from the function.
 chargeCoffee :: Coffee -> DebitCard -> Maybe DebitCard
-chargeCoffee = error "TODO: chargeCoffee"
+chargeCoffee coffee card
+  | price coffee <= balance card = Just card {balance=balance card - price coffee} 
+  | otherwise = Nothing
 
 -- | How was the coffee charged.
 data PaymentMethod
@@ -327,7 +331,15 @@ data Customer
 -- NOTE: The customer can only buy a coffee with strictly one payment method.
 --   (Only one card or cash)
 payForCoffee :: Customer -> Coffee -> Maybe PaymentMethod
-payForCoffee = error "TODO: payForCoffee"
+payForCoffee customer coffee =
+  let checkCard = chargeCoffee coffee
+      goodCards :: Maybe PaymentMethod
+      goodCards = fmap Card $ listToMaybe $ mapMaybe checkCard (cards customer)
+      cashOption = if cash customer >= price coffee then
+                    Just $ Cash (cash customer - price coffee)
+                  else 
+                    Nothing
+   in goodCards <|> cashOption 
 
 -- | This function should apply the chosen payment method to the customer.
 -- In other words, it needs to apply the charge to the customer himself
@@ -338,12 +350,21 @@ payForCoffee = error "TODO: payForCoffee"
 --
 -- NOTE: You can not change the order of the cards.
 applyPayment :: Customer -> PaymentMethod -> Customer
-applyPayment = error "TODO: applyPayment"
+applyPayment customer paymentMethod =
+  case paymentMethod of 
+    Cash change -> customer {cash = change }
+    Card chargedCard ->
+      let newCards = fmap (\card -> if cardId card == cardId chargedCard then chargedCard else card ) $ cards customer
+      in customer {cards = newCards}
+   
 
 -- | Performs the full payment (as in 'payForCoffee') and
 -- returns the modified customer (as in 'applyPayment').
 buyCoffee :: Customer -> Coffee -> Maybe Customer
-buyCoffee = error "TODO: buyCoffee"
+buyCoffee customer coffe =
+  let maybePaymentMethod =  payForCoffee customer coffe  in
+    fmap (applyPayment customer) maybePaymentMethod
+
 
 -- | You know that due to a medical condition the customer needs to watch his
 -- sugar intake. The new privacy-invading piece of ... technology can now
@@ -357,7 +378,14 @@ buyCoffee = error "TODO: buyCoffee"
 --
 -- NOTE: You can not change the order of the coffee.
 saveTheDiabetic :: [Coffee] -> (RUBAmount, [Coffee])
-saveTheDiabetic = error "TODO: saveTheDiabetic"
+saveTheDiabetic coffeeList = 
+  let isSugar = (`elem` [WhiteSugar, BrownSugar])
+      sugarPrice extra = if isSugar extra then price extra else 0
+      savedMonney = foldl (\savedMonney coffee -> savedMonney + (sum $ fmap sugarPrice $ extras coffee))
+                          0 coffeeList
+      coffeesWithoutSugar = fmap (\coffee -> coffee {extras = filter (not . isSugar) $ extras coffee} ) coffeeList
+  in (savedMonney, coffeesWithoutSugar)
+  
 
 -- | And just to torment those who love sugar lets make a function which
 -- calculates health hazard (sugar content) of the given orders.
@@ -367,4 +395,11 @@ saveTheDiabetic = error "TODO: saveTheDiabetic"
 --   WhiteSugar: 2 extra danger points
 --   BrownSugar: 1 extra danger point
 calculateSugarDanger :: [Coffee] -> Int
-calculateSugarDanger = error "TODO: calculateSugarDanger"
+calculateSugarDanger coffeeList = sum $ fmap (
+  \extra -> case extra of
+    WhiteSugar -> 2
+    BrownSugar -> 1
+    _ -> 0) (coffeeList >>= extras)
+
+-- (>>=) :: m a -> (a -> m b) -> m b
+-- (>>=) :: [a] -> (a -> [b]) -> [b]

seminars/2/package.yaml

@@ -5,6 +5,7 @@ license:             Unlicense
 dependencies:
   - base >= 4.7 && < 5
   - mtl
+  - QuickCheck
 
 library:
   source-dirs:      src

seminars/2/src/Task.hs

@@ -1,5 +1,10 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
 module Task
   ( calculate,
+    Expr(..),
   )
 where
 
@@ -7,6 +12,179 @@ import Control.Applicative
 import Control.Monad.State.Lazy
 import Data.Char
 import Data.Maybe
+import Test.QuickCheck
+import Text.Read
+import Debug.Trace
+import Control.Monad
+
+type ParsingResult a = Either String (a, String)
+
+-- Parser :: Type -> Type
+newtype Parser a = Parser (String -> ParsingResult a) 
+  deriving Functor
+
+instance Applicative Parser where
+  pure :: a -> Parser a
+  pure x = Parser (\q -> Right (x, q))
+
+  (<*>) :: Parser (a -> b) -> Parser a -> Parser b
+  (<*>)
+    (Parser (e :: String -> ParsingResult (a -> b))) 
+    (Parser (x :: String -> ParsingResult a)) = Parser (\s -> 
+    case e s of
+    Left err -> Left err
+    Right (arr, sLeft) -> case x sLeft of
+        Left err2 -> Left err2
+        Right (resOfTypeA, sLeft2) -> Right (arr resOfTypeA, sLeft2))
+        
+instance Monad Parser where
+  return :: a -> Parser a
+  return = pure
+  
+  (>>=) :: Parser a -> (a -> Parser b) -> Parser b
+  (>>=) (Parser x) e = Parser (\s -> 
+    case x s of
+      Left err -> Left err
+      Right (a, s1) -> case e a of
+        Parser f -> f s1
+    )
+
+instance MonadFail Parser where
+  fail :: String -> Parser a
+  fail err = Parser . const . Left $ err
+
+instance Alternative Parser where
+  empty :: Parser a
+  empty = Parser . const . Left $ "I'm empty"
+
+  (Parser left) <|> (Parser right) = Parser $ \s -> case (left s, right s) of
+    (Right res, _) -> Right res
+    (Left _, Right res) -> Right res
+    (Left err1, Left err2) -> Left $ "Both alternatives failed: 1) " ++ err1 ++ "\n2:" ++ err2
+
+anyToken :: Parser Char
+anyToken = Parser $ \s -> case s of
+  "" -> Left "Empty String"
+  (hd: tl) -> Right (hd, tl)
+
+eos :: Parser ()
+eos = Parser $ \s -> case s of
+  "" -> Right ((), "")
+  s -> Left $ "unexpected trailing content: " ++ s
+
+token :: Char -> Parser ()
+-- token expected = Parser $ \s -> case s of
+--   "" -> Left "Empty String"
+--   (hd: tl) -> if hd == expected then Right ((), tl) else Left  $ 
+token expected = do
+  actual <- anyToken
+  when (actual /= expected) $ fail $ "expected " ++ [expected] ++ ", got " ++ [actual]
+-- when :: Applicative f => Bool -> f () -> f ()
+
+tokens :: String -> Parser ()
+tokens "" = pure ()
+tokens (c: cs) = do
+  token c
+  tokens cs
+
+-- "x"
+-- u <- tokensWhile (== 'a')
+
+tokensWhile :: (Char -> Bool) -> Parser String
+-- tokensWhile e = (do
+--   char <- anyToken
+--   str <- if e char then tokensWhile e else empty
+--   pure (char:str)) <|> (pure "")
+-- tokensWhile e = (do
+--   char <- anyToken
+--   str <- if e char then tokensWhile e else empty
+--   pure (char:str)) <|> (pure "")
+
+tokensWhile e = tokensWhile1 e <|> pure ""
+
+tokensWhile1 :: (Char -> Bool) -> Parser String
+tokensWhile1 e = do
+  char <- anyToken
+  -- traceShowM char
+  str <- if e char then tokensWhile e else empty
+  pure (char:str)
+
+-- isDigit :: Char -> Bool
+
+-- TODO: add negative numbers
+number:: Parser Int
+number = do
+  chars <- tokensWhile1 isDigit
+  case readMaybe chars of
+    Just res -> return res
+    Nothing -> fail $ "unexpected invalid number: '" ++ chars ++ "'"
+
+data Expr 
+  = Num Int 
+  | AddExpr Expr Expr 
+  | MulExpr Expr Expr 
+  | SubExpr Expr Expr 
+  | DivExpr Expr Expr
+  deriving Show
+
+half :: Gen a -> Gen a
+half = scale (`div` 2)
+
+instance Arbitrary Expr where
+  arbitrary = do
+    size <- getSize 
+    case size of 
+      0 -> Num <$> arbitrary 
+      otherwise ->
+        oneof [
+          Num <$> arbitrary,
+          AddExpgr <$> half arbitrary <*> half arbitrary,
+          SubExpr <$> half arbitrary <*> half arbitrary,
+          MulExpr <$> half arbitrary <*> half arbitrary,
+          DivExpr <$> half arbitrary <*> half arbitrary
+          ]
+
+parse :: Parser Expr
+parse = Num <$> number <|> (do
+    token '('
+    tokensWhile isSpace
+    expr1 <- parse
+    tokensWhile isSpace
+    operator <- anyToken  
+    tokensWhile isSpace
+    expr2 <- parse
+    tokensWhile isSpace
+    token ')'
+    case operator of
+      '+' -> return $ AddExpr expr1 expr2
+      '*' -> return $ MulExpr expr1 expr2
+      '-' -> return $ SubExpr expr1 expr2
+      '/' -> return $ DivExpr expr1 expr2
+      _ -> fail "unknown operator"
+  )
+
+parseFull :: Parser Expr
+parseFull = do
+  e <- parse
+  eos
+  return e
+
+evaluate :: Expr -> Maybe Int
+evaluate (Num x) = Just x
+evaluate (AddExpr left right) = (+) <$> (evaluate left) <*> (evaluate right)
+evaluate (MulExpr left right) = (*) <$> (evaluate left) <*> (evaluate right)
+evaluate (SubExpr left right) = (-) <$> (evaluate left) <*> (evaluate right)
+evaluate (DivExpr _ right) | evaluate right == Just 0 = Nothing
+evaluate (DivExpr left right) = div <$> (evaluate left) <*> (evaluate right)
+
+
+runParser :: Parser x -> String -> Maybe x
+runParser (Parser parser_fun) context = 
+  case parser_fun context of 
+   Left msg -> trace msg Nothing
+   Right (x, _) -> Just x
 
 calculate :: String -> Maybe Int
-calculate = error "TODO: calculate"
+calculate s = do
+  expression <- runParser parseFull s
+  evaluate expression

seminars/2/task.cabal

@@ -4,7 +4,7 @@ cabal-version: 2.2
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 20a39a4ec02d6e75694b336bd8631bf5d630fcaacb76de84c7263c8abe1c45b3
+-- hash: c2b1bcd2599c61a3fda41614499046ca5654131a2e5ac9976e0c07ec2b8887d8
 
 name:           task
 version:        0.1.0.0
@@ -21,7 +21,8 @@ library
   hs-source-dirs:
       src
   build-depends:
-      base >=4.7 && <5
+      QuickCheck
+    , base >=4.7 && <5
     , mtl
   default-language: Haskell2010
 
@@ -36,7 +37,8 @@ test-suite task-tests
   hs-source-dirs:
       test
   build-depends:
-      base >=4.7 && <5
+      QuickCheck
+    , base >=4.7 && <5
     , mtl
     , task
     , tasty