-- vim: tw=80 cc=81 spelllang=cs spell module BRP ( Car, Person, Database, createCar, addResident, updateCar, deleteResident, carPrice, payForCar, unparkCar, fines, visitors, potential, interactive, exampleDB ) where import Data.Set ( Set ) import qualified Data.Set as Set import Data.Map ( Map ) import qualified Data.Map as Map newtype Car = Car String deriving (Eq, Ord, Show) data Person = Person { idnum :: Int, name :: String, surname :: String } deriving (Show) instance Eq Person where p1 == p2 = idnum p1 == idnum p2 instance Ord Person where p1 <= p2 = idnum p1 <= idnum p2 type Money = Integer type Time = Money -- | Pokuta za parkování mimo zóny parkování nebo v parkovacích zónách se -- statusem Residents, pokud zaparkovaný vůz není zapsán na některého residenta. fine :: Money fine = 50 -- | Poplatek za odtah vozidla. Vizte 'interactive' pro kontext. towing :: Money towing = 100 -- | Vůz, který dostal pokutu navíc za každou minutu na pokutovaném místě zaplatí -- 'fineMultiplier' * {počet zaparkovaných minut} peněz fineMultiplier :: Money fineMultiplier = 5 data Carrecord = Carrecord Car Time Zone deriving (Show) instance Eq Carrecord where Carrecord c1 _ _ == Carrecord c2 _ _ = c1 == c2 instance Ord Carrecord where Carrecord c1 _ _ <= Carrecord c2 _ _ = c1 <= c2 fstcrec :: Carrecord -> Car fstcrec (Carrecord x _ _) = x sndcrec :: Carrecord -> Time sndcrec (Carrecord _ x _) = x thdcrec :: Carrecord -> Zone thdcrec (Carrecord _ _ x) = x data Zonetype = Residents | Visitors deriving (Eq, Show) type Zone = String type Zones = Map Zone Zonetype type Parked = Set Carrecord -- Nocar se nesmí objevit ve druhé složce jako klíč type Residents = (Map Person (Maybe Car), Map Car Person) type Database = (Residents, Zones, Parked) -- | Vrátí hodnotu automobilového typu za předpokladu, že má řetězec tvar -- poznávací značky. -- -- Tvar poznávací značky je následující: -- -- @{Čís}{VP}{Čís|VP}{mezera}{Čís}{Čís}{Čís}{Čís}@ kde @{Čís}@ je libovolná číslice -- a @{VP}@ je libovolné velké písmeno anglické abecedy, kromě G, O, Q, W. -- -- Pokud nemá řetězec požadovaný tvar, vrátí Nothing, jinak vrátí řetězec -- zabalený do konstruktorů 'Just' 'Car' -- -- __V celém zbytku řešení je zakázáno používat konstruktor 'Car' k vytváření__ -- __hodnot typu 'Car' (tedy je povoleno jej používat právě k pattern matchingu).__ createCar :: String -- ^ poznávací značka -> Maybe Car createCar str = if (take 9 str ++ "$") `matches` [cis, vp, cis ++ vp, " ", cis, cis, cis, cis, "$", ""] then Just $ Car str else Nothing where string `matches` pattern = and $ zipWith elem string pattern cis = ['0'..'9'] vp = filter (`notElem` "GOQW") ['A'..'Z'] -- | Přidá nového residenta. -- -- Pokud již daná osoba je uložena, nebo daný vůz napsaný na některou osobu, -- vrátí funkce hodnotu nezměněného prvního argumentu. -- -- Pokud je jako samohyb předána hodnota 'Nothing' je přidána osoba bez -- přiřazeného samohybu. addResident :: Residents -- ^ residenti -> Person -- ^ osoba k přidání -> Maybe Car -- ^ samohyb patřící osobě -> Residents addResident residents@(frs, scn) person car = if person `Map.member` frs || maybe False (`Map.member` scn) car then residents else (Map.insert person car frs, maybe scn flipinsert car) where flipinsert cara = Map.insert cara person scn -- | Změní vůz napsaný na danou osobu, případně přiřadí vůz nový, pokud na danou -- osobu zatím žádný vůz napsán nebyl. Pokud je již vůz napsán u jiné osoby nebo -- osoba vůbec není uložena jako resident, je vrácen první argument nezměněn. -- Pokud je jako nový samohyb předána hodnota 'Nothing', odebere jakýli vůz -- přiřazený k dané osobě z databáze residentů. updateCar :: Residents -- ^ residenti -> Person -- ^ osoba s novým samohybem -> Maybe Car -- ^ nový samohyb -> Residents updateCar residents@(frs, scn) person car = if person `Map.notMember` frs || maybe False (`Map.member` scn) car then residents else (Map.adjust (const car) person frs, maybe deleted flipinsert car) where oldcar = Map.findWithDefault Nothing person frs deleted = maybe scn (`Map.delete` scn) oldcar flipinsert cara = Map.insert cara person deleted -- | Odstraní osobu (a s ní asociovaný samohyb) z residentů. Pokud osoba nebyla -- residentem, je vrácen první argument beze změn. deleteResident :: Residents -- ^ residenti -> Person -- ^ osoba odstanuvší se residentem -> Residents deleteResident residents@(frs, scn) person = if person `Map.notMember` frs then residents else (Map.delete person frs, deleted) where oldcar = Map.findWithDefault Nothing person frs deleted = maybe scn (`Map.delete` scn) oldcar defrec :: Car -> Carrecord defrec x = Carrecord x 0 "" setlookup :: Ord a => a -> Set a -> Maybe a setlookup el set = flip Set.elemAt set <$> Set.lookupIndex el set -- | Cena, kterou musí zaplatit majitel daného vozidla, aby je mohl odparkovat v -- této chvíli. Vozidlo lze odparkovat jen tehdy, pokud je hodnota této funkce -- pro toto vozidlo rovna 0. -- -- Cena se počítá různě podle následujícího: -- -- * pokud je vůz zapsán na nějakého residenta a stojí v libovolné zóně -- uložené v databasi, pak je cena rovna 0. -- -- * pokud vůz v databasi residentů není a stojí v zóně označené jako -- Visitors, pak je cena rovna délce zaparkování, tedy -- @{aktuální čas} – {čas zaparkování}@ -- -- * ve všech jiných případech je vůz pokutován a cena se tedy rovná pokutě, -- ke které je přičtena zvýšená minutová taxa, tedy -- @'fine' + 'fineMultiplier' * ({aktuální čas} – {čas zaparkování})@ carPrice :: Database -- ^ městská database -> Time -- ^ aktuální čas -> Car -- ^ samohyb doličný -> Integer carPrice database@(residents, _, parked) time car = maybe 0 carrecPrice (setlookup (defrec car) parked) where carrecPrice carrec | Set.member carrec (fines database) = fine + fineMultiplier * (time - sndcrec carrec) | Map.member (fstcrec carrec) (snd residents) = 0 | otherwise = time - sndcrec carrec -- | Přidá vozidlo do database zaparkovaných vozidel spolu s názvem zóny, kde je -- zaparkováno (ať existuje, nebo ne). Uloží aktuální čas jako čas zaparkování. -- -- Pokud dané vozidlo již je v databasi zaparkovaných vozidel, pak dojde k -- přeparkování vozidla jen tehdy, když může být napřed odparkováno pomocí -- 'unparkCar', což je právě tehdy, když jeho 'carPrice' je rovna 0. parkCar :: Database -- ^ městská database -> Time -- ^ aktuální čas -> Zone -- ^ název parkovací zóny -> Car -- ^ samohyb doličný -> Parked parkCar database@(_, _, parked) time zone car = (if carPrice database time car == 0 then Set.insert (Carrecord car time zone) else id) parked -- | Nastaví dobu parkování tak, aby aktuální cena za parkování ('carPrice') -- byla rovna 0. Může pro tento účel nastavit čas zaparkování i do budoucnosti. -- -- Tedy nastaví čas zaparkování samohybu na: -- -- * @aktuální čas@, pokud samohyb není zatížen pokutou, -- -- * @aktuální čas + 'fine' \`div\` 'fineMultiplier'@, pokud zatížen pokutou -- je. payForCar :: Database -- ^ městská database -> Time -- ^ aktuální čas -> Car -- ^ samohyb doličný -> Parked payForCar database@(_, _, parked) time car = maybe parked payforCarrec (setlookup (defrec car) parked) where payforCarrec carrec = Set.insert (Carrecord car (time + tdelta carrec) (thdcrec carrec)) parked tdelta carrec = if carrec `elem` fines database then fine `div` fineMultiplier else 0 -- | Odebere automobil z database zaparkovaných vozidel, pokud je za něj uhrazen -- příslušný poplatek za parkování či příslušná pokuta, tedy jeho carPrice je -- rovna 0. unparkCar :: Database -- ^ městská database -> Time -- ^ aktuální čas -> Car -- ^ samohyb doličný -> Parked unparkCar database@(_, _, parked) time car = (if carPrice database time car == 0 then Set.delete (defrec car) else id) parked -- | Vrátí databasi zaparkovaných vozidel ochuzenou o vozidla, která NEJSOU -- pokutována (vrátí tedy právě ta pokutovaná). fines :: Database -- ^ městská database -> Parked fines (residents, zones, parked) = Set.filter filterfunc parked where filterfunc x = maybe True (not . (resident x ||) . (==Visitors)) $ (flip Map.lookup zones . thdcrec) x resident = flip Map.member (snd residents) . fstcrec -- | Vrátí databasi zaparkovaných vozidel ochuzenou o vozidla, která NEJSOU -- zatížena BĚŽNÝM poplatkem za parkování (nikoliv pokutou). visitors :: Database -- ^ městská database -> Parked visitors (residents, zones, parked) = Set.filter filterfunc parked where filterfunc x = maybe False ((notresident x &&) . (==Visitors)) $ (flip Map.lookup zones . thdcrec) x notresident = not . flip Map.member (snd residents) . fstcrec -- | Vrátí množství peněz, které by připutovaly do městské pokladnice, pokud by -- za všechna aktuálně zaparkovaná vozidla byly v aktuální chvíli zaplaceny -- všechny pokuty a poplatky, kterými jsou ta která vozidla zatížena. potential :: Database -- ^ městská database -> Time -- ^ aktuální čas -> Integer potential database@(_, _, parked) time = sum $ Set.map (carPrice database time . fstcrec) parked -- | Interaktivní přístup k městské databasi mající následující funkce: -- -- * Je lze ho ukončit. -- -- * Zvýší čítač času o 1 a zobrazí nový čas. -- -- * Výpočet množství peněz, které by připutovaly do pokladnice při okamžitém -- zaplacení všech pohledávek (vizte 'potential'). -- -- * Zaparkování vozu v dané zóně. Zóna nemusí existovat, v tom případě bude -- vypsáno upozornění o pokutě. Stejně tak, pokud osoba je návštěvníkem a -- parkuje v residentské zóně. Nedovolí zaparkovat vůz, který již zaparkován -- je. Vůz, který není vozem (dle 'createCar') zaparkován nebude! -- -- * Zaplacení poplatku/pokuty za zaparkované vozidlo. Vypíše, kolik bylo -- zaplaceno. Ošetřete neexistenci vozidla. -- -- * Odparkování vozu. Bude provedeno pouze tehdy, pokud vozidlo není zatíženo -- poplatkem, ani pokutou (uživatel bude informován, zda bylo vozidlo -- odparkováno). Ošetřete neexistenci vozidla. -- -- * Výpis všech dostupných informací, tedy: -- -- * aktuální čas -- -- * peníze doposud utržené -- -- * výpis residentů seřazených podle čísel OP (i s jim přiřazeným vozem, -- je-li takový) -- -- * výpis zaparkovaných vozů a jejich aktuální hodnota (vizte 'carPrice') -- -- * „Odtah“ všech pokutovaných vozidel, do utržených financí se započítají -- pokuty a navíc 100 peněz za odtah každého jednoho vozidla. -- -- Provedení libovolné funkce krom čekání netrvá žádný čas. -- -- Funkce vrací nový stav database, nový čas a peníze utržené za zaplacení pokut -- a parkovacích poplatků za dobu běhu interaktivního asistentu. interactive :: Database -- ^ počáteční městská database -> Time -- ^ počáteční čas -> IO (Database, Time, Money) interactive database time = putStrLn "Vítáme vás v systému BRP." >> mainLoop time 0 database mainLoop :: Time -> Money -> Database -> IO (Database, Time, Money) mainLoop tm mn db@(residents@(frs, _), zones, parked) = do putStrLn "\nCo chcete provést za akci?\n\ \ [1] – peníze aktuálně vybratelné za parkování\n\ \ [2] – odtáhnout nepatřičné samohyby\n\ \ [3] – zaparkovat vůz\n\ \ [4] – zaplatit za zaparkovaný vůz\n\ \ [5] – odparkovat vůz\n\ \ [6] – vypsat informace z databáze\n\ \ [w] – zvýšit časomíru o minutu\n\ \ [q] – skončit tohoto asistenta" option <- getChar putStrLn "\n---------" case option of '1' -> do putStr "V parkování je \"uloženo\" " putStr (show (potential db tm)) putStrLn " peněz." mainLoop tm mn db '2' -> let mnTowing = (toInteger . Set.size $ fines db) * towing mnFines = sum . Set.map (carPrice db tm . fstcrec) $ fines db newmn = mn + mnTowing + mnFines newParked = parked `Set.difference` fines db in mainLoop tm newmn (residents, zones, newParked) '3' -> parkCarRoutine >>= mainLoop tm mn '4' -> payCarRoutine >>= uncurry (mainLoop tm) '5' -> unparkCarRoutine >>= mainLoop tm mn '6' -> listRoutine >> mainLoop tm mn db 'w' -> do let ntm = tm+1 putStrLn ("Je o minutu více, aktuálně je tedy " ++ show ntm) mainLoop ntm mn db 'q' -> return (db, tm, mn) _ -> putStrLn "Neznámý příkaz, zkuste to znovu." >> mainLoop tm mn db where withReadCar :: IO a -> (Car -> IO a) -> IO a withReadCar nothingAction justCarAction = do putStr "Zadejte poznávací značku vozu: " maybeCar <- createCar <$> getLine maybe (putStrLn "Tohle není SPZ skutečného vozidla!" >> nothingAction) justCarAction maybeCar parkCarRoutine = withReadCar (return db) $ \car -> if Set.member (defrec car) parked then putStrLn "Vůz je již zaparkován jinde" >> return db else do putStr "Zadejte název parkovací zóny: " zonename <- getLine let newdb = (residents, zones, parkCar db tm zonename car) let message | defrec car `elem` fines newdb = "Parkutjete, kde nemáte, při odparkování budete platit pokutu." | defrec car `elem` visitors newdb = "Vítejte, za každou zaparkovanou minutu zaplatíte jeden peníz." | otherwise = "Vítej doma, brňane." putStrLn message return newdb payCarRoutine = withReadCar (return (mn, db)) $ \car -> if defrec car `notElem` parked then putStrLn "Tento vůz není nikde ve Štatlu zaparkován." >> return (mn, db) else do let price = carPrice db tm car putStrLn $ "Za toto vozidlo jste zaplatili " ++ show price ++ " peněz." return (mn + price, (residents, zones, payForCar db tm car)) unparkCarRoutine = withReadCar (return db) $ \car -> if defrec car `notElem` parked then putStrLn "Tento vůz zde není zaparkován." >> return db else if carPrice db tm car /= 0 then putStrLn "Musíte napřed zaplatit." >> return db else putStrLn "Vůz odparkován." >> return (residents, zones, unparkCar db tm car) listRoutine = do putStrLn $ "Je " ++ show tm ++ " minut.\n" putStrLn $ "Do městké pokladnice za dobu běhu klientu přibylo " ++ show mn ++ " peněz.\n" putStrLn $ "Residenti ve tvaru OP Jméno Příjmení Automobil" sequence_ (Map.mapWithKey printRes frs) putStrLn "\nZaparkovaná auta ve tvaru SPZ Zóna Čas zaparkování Hodnota vozu (v aktuální chvíli)" sequence_ (Set.mapMonotonic printCarrec parked) putStr "\n" unCar (Car x) = x printRes (Person idnum_ name_ surname_) car = putStrLn $ show idnum_ ++ " " ++ name_ ++ " " ++ surname_ ++ " " ++ maybe "Žádný vůz" unCar car printCarrec (Carrecord car time zone) = putStrLn $ unCar car ++ " " ++ zone ++ " " ++ show time ++ " " ++ show (carPrice db tm car) exampleRes :: Residents exampleRes = (Map.fromList (map (\(c, p) -> (p, Just c)) carpeople), Map.fromList carpeople) where carpeople = [(Car "2B8 1906", Person 1 "Kurt" "Gödel"), (Car "0T3 1854", Person 2 "Leoš" "Janáček"), (Car "2M0 1822", Person 3 "Řehoř" "Mendel")] exampleZon :: Zones exampleZon = Map.fromList [("Svoboďák", Residents), ("Hrnčířská", Visitors)] examplePar :: Parked examplePar = Set.fromList [Carrecord (Car "2B8 1906") 1 "Na střeše petrova", Carrecord (Car "0T3 1854") 5 "Hrnčířská", Carrecord (Car "0B0 0007") 4 "Svoboďák", Carrecord (Car "1A2 3456") 42 "Hrnčířská", Carrecord (Car "2M0 1822") 7 "Svoboďák"] exampleDB :: Database exampleDB = (exampleRes, exampleZon, examplePar)