From 2d9cfd818d293d417c0a9510903ae9da4b651747 Mon Sep 17 00:00:00 2001 From: Tissevert Date: Sun, 14 Apr 2019 19:20:24 +0200 Subject: [PATCH] Implement scheduling and make it the default mode --- pilu.cabal | 3 ++ src/CLI.hs | 8 ++--- src/CSV.hs | 8 ++--- src/Event.hs | 6 ++-- src/Main.hs | 25 +++++++++------- src/Medicine.hs | 4 +-- src/Schedule.hs | 80 +++++++++++++++++++++++++++++++++++++++++++++++++ src/Timeline.hs | 51 +++++++++++++------------------ src/YAML.hs | 49 ++++++++++++++++++++++++++++++ 9 files changed, 180 insertions(+), 54 deletions(-) create mode 100644 src/Schedule.hs create mode 100644 src/YAML.hs diff --git a/pilu.cabal b/pilu.cabal index 8db2174..187ce1d 100644 --- a/pilu.cabal +++ b/pilu.cabal @@ -22,7 +22,9 @@ executable pilu , Event , Medicine , Paths_pilu + , Schedule , Timeline + , YAML -- other-extensions: build-depends: base >=4.9 && <4.13 , containers @@ -30,5 +32,6 @@ executable pilu , optparse-applicative , parsec , time + ghc-options: -Wall -dynamic hs-source-dirs: src default-language: Haskell2010 diff --git a/src/CLI.hs b/src/CLI.hs index 5a5cc30..7ffbb51 100644 --- a/src/CLI.hs +++ b/src/CLI.hs @@ -4,7 +4,7 @@ module CLI ( ) where import Options.Applicative ( - Parser, execParser, flag, flag', fullDesc, header, help, helper, info, long + Parser, execParser, flag, flag', fullDesc, header, help, helper, info, long, short ) import Control.Applicative ((<**>), (<|>)) import Data.Monoid ((<>)) @@ -18,9 +18,9 @@ versionStr = showVersion Pilu.version invocation :: Parser Invocation invocation = - flag' Schedule - (long "schedule" <> help "Show when next to go for provisioning") - <|> flag Inventory (Version versionStr) + flag' Inventory + (short 'i' <> long "inventory" <> help "Show a full inventory") + <|> flag Schedule (Version versionStr) (long "version" <> help "Show the version number") invoked :: IO Invocation diff --git a/src/CSV.hs b/src/CSV.hs index 4190a58..97a5665 100644 --- a/src/CSV.hs +++ b/src/CSV.hs @@ -32,11 +32,11 @@ quoted = char '"' *> many quotedChar <* char '"' "quote ending the cell" parse :: Row a => String -> Char -> String -> Either ParseError [a] parse name separator input = do - lines <- Parsec.parse (csvFile separator) name input - case lines of + rows <- Parsec.parse (csvFile separator) name input + case rows of [] -> Right [] - (header:rows) -> - let assocs = Map.fromList . zipWith (,) header <$> rows in + (header:contents) -> + let assocs = Map.fromList . zipWith (,) header <$> contents in sequence $ zipWith parseRow [1..] assocs where parseRow n row = either (errorAt n) return $ fromRow row diff --git a/src/Event.hs b/src/Event.hs index 6a2db63..c4ae2dc 100644 --- a/src/Event.hs +++ b/src/Event.hs @@ -5,7 +5,7 @@ module Event ( import CSV (Row(..)) import Control.Monad (foldM) -import Data.List (isSuffixOf, takeWhile, sortOn) +import Data.List (isSuffixOf, takeWhile) import Data.Map (Map) import qualified Data.Map as Map (delete, empty, insert, lookup, toList) import Data.Time (Day) @@ -22,11 +22,11 @@ data Event = Event { instance Row Event where fromRow assoc = do - date <- read <$> get "date" + rowDate <- read <$> get "date" (kind, ints) <- foldM addAmount (Nothing, Map.empty) . Map.toList $ Map.delete "date" assoc maybe (Left $ Expect "A prescription or provisioning for a medicine") - (Right . Event date ints) + (Right . Event rowDate ints) kind where get key = maybe (Left $ Expect key) Right $ Map.lookup key assoc diff --git a/src/Main.hs b/src/Main.hs index 7d74f63..158767e 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,12 +1,14 @@ +{-# LANGUAGE NamedFieldPuns #-} module Main where import CLI (Invocation(..), invoked) import CSV (Row, parse) import Data.Time (UTCTime(..), getCurrentTime) -import Event (Event) -import Medicine (Medicine, Pharmacy, pharmacy) +import Medicine (Pharmacy, pharmacy) import System.Exit (exitFailure, exitSuccess) -import Timeline (State, currentState) +import Schedule (schedule) +import Timeline (State(..), stateAt) +import YAML (encode) readCSV :: Row a => FilePath -> IO [a] readCSV filePath = do @@ -15,17 +17,20 @@ readCSV filePath = do Left e -> (putStrLn $ show e) >> exitFailure Right rows -> return rows -getCurrentState :: IO State -getCurrentState = - currentState +getState :: Pharmacy -> IO State +getState aPharmacy = + stateAt <$> (utctDay <$> getCurrentTime) - <*> (pharmacy <$> readCSV "medicine.csv") + <*> (return aPharmacy) <*> readCSV "timeline.csv" main :: IO () main = do invocation <- invoked - case invocation of - Inventory -> show <$> getCurrentState >>= putStrLn - Schedule -> putStrLn "schedule" + display <- case invocation of + Inventory -> return $ const encode + Schedule -> return $ \ph -> encode . schedule ph Version version -> putStrLn version >> exitSuccess + thePharmacy <- pharmacy <$> readCSV "medicine.csv" + theState <- getState thePharmacy + putStrLn $ display thePharmacy theState diff --git a/src/Medicine.hs b/src/Medicine.hs index 1c7277b..3736356 100644 --- a/src/Medicine.hs +++ b/src/Medicine.hs @@ -3,7 +3,6 @@ module Medicine ( Medicine(..) , MedicineName , Pharmacy - , Stock , pharmacy ) where @@ -16,18 +15,19 @@ type MedicineName = String data Medicine = Medicine { name :: MedicineName + , content :: Float , minStock :: Float } deriving (Show) instance Row Medicine where fromRow assoc = Medicine <$> get "name" + <*> (read <$> get "content") <*> (read <$> get "minStock") where get key = maybe (Left $ Expect key) Right $ Map.lookup key assoc type Pharmacy = Map MedicineName Medicine -type Stock = Map MedicineName Float pharmacy :: [Medicine] -> Pharmacy pharmacy = foldr (\medicine -> Map.insert (name medicine) medicine) Map.empty diff --git a/src/Schedule.hs b/src/Schedule.hs new file mode 100644 index 0000000..84d6879 --- /dev/null +++ b/src/Schedule.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE FlexibleInstances #-} +module Schedule ( + schedule + ) where + +import Data.Map ((!), Map, elems, lookupMin, mapWithKey, partition, size) +import qualified Data.Map as Map (filter) +import Data.Time (Day, addDays) +import Medicine (Medicine(..), MedicineName, Pharmacy) +import Timeline (State(..)) +import YAML ((.:), Value(..), YAML(..)) + +data ScheduleType = NextBox | Provision | OutOfStock deriving (Eq, Show) + +instance YAML ScheduleType where + toYAML NextBox = Simple "start a new box" + toYAML Provision = Simple "go to the pharmacy get some more" + toYAML OutOfStock = Simple "out of it" + +data Schedule = Schedule { + days :: Integer + , date :: Day + , scheduleType :: ScheduleType + } deriving (Show) + +instance YAML (Map MedicineName Schedule) where + toYAML schedules = Object $ outOfStocks ++ nextDay + where + (urgent, normal) = partition ((== OutOfStock) . scheduleType) schedules + outOfStocks = + if size urgent > 0 + then ["Warning ! Out of" .: (Object . timing <$> urgent)] + else [] + nextDay = maybe [] (scheduleNext normal) (snd <$> lookupMin normal) + +scheduleNext :: Map MedicineName Schedule -> Schedule -> [(String, Value)] +scheduleNext schedules aSchedule = ["Schedule" .: (Object $ + timing aSchedule + ++ ["TODO" .: (scheduleType <$> schedules)] + )] + +timing :: Schedule -> [(String, Value)] +timing aSchedule = + ["On" .: date aSchedule, "In" .: (show (days aSchedule) ++ " days")] + +zipWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c +zipWithKey f as bs = + mapWithKey (\k -> f k $ as ! k) bs + +scheduleByMedicine :: Pharmacy -> Day -> MedicineName -> Float -> Float -> Schedule +scheduleByMedicine pharmacy day medicineName stockLeft rate = + let (scheduleType, amount) = typeAndAmount stockLeft minStock leftInBox in + let days = truncate (amount / rate) in + Schedule {days, date = days `addDays` day, scheduleType} + where + (Medicine {minStock, content}) = pharmacy ! medicineName + truncateF = fromInteger . truncate + leftInBox = content - (truncateF (content / stockLeft) * stockLeft) + +typeAndAmount :: Float -> Float -> Float -> (ScheduleType, Float) +typeAndAmount stockLeft minStock leftInBox = + if secureLeft > 0 + then + if secureLeft < leftInBox + then (Provision, secureLeft) + else (NextBox, leftInBox) + else (OutOfStock, stockLeft) + where + secureLeft = stockLeft - minStock + +schedule :: Pharmacy -> State -> Map MedicineName Schedule +schedule pharmacy (State {day, stock, consumptionRate}) = + Map.filter keep schedules + where + schedules = + zipWithKey (scheduleByMedicine pharmacy day) stock consumptionRate + minDays = minimum . elems $ days <$> schedules + keep aSchedule = + days aSchedule == minDays || scheduleType aSchedule == OutOfStock diff --git a/src/Timeline.hs b/src/Timeline.hs index 1f11146..95bfe4a 100644 --- a/src/Timeline.hs +++ b/src/Timeline.hs @@ -1,40 +1,31 @@ {-# LANGUAGE NamedFieldPuns #-} module Timeline ( - State - , currentState + State(..) + , stateAt ) where -import Control.Monad (foldM, join) -import Control.Monad.Reader (Reader, runReader, ask) import Data.List (sortOn) -import Data.Map ((!), Map, mapWithKey, toList) +import Data.Map ((!), Map, mapWithKey) import Data.Time (Day, diffDays) import Event (Event(..), EventType(..)) -import Medicine (Pharmacy, Stock) - -type ConsumptionRate = Map String Float +import Medicine (MedicineName, Pharmacy) +import YAML ((.:), Value(..), YAML(..)) data State = State { day :: Day - , stock :: Stock - , consumptionRate :: ConsumptionRate + , stock :: Map MedicineName Float + , consumptionRate :: Map String Float } -instance Show State where - show (State {day, stock, consumptionRate}) = unlines $ - ("day: " ++ show day) - : ("stock:" : (indent <$> showAssoc stock) :: [String]) - ++ ("consumptionRate:" : (indent <$> showAssoc consumptionRate)) - where - indent :: String -> String - indent = ('\t' :) - showAssoc :: Show a => Map String a -> [String] - showAssoc = fmap (\(key, val) -> key ++ ": " ++ show val) . toList +instance YAML State where + toYAML (State {day, stock, consumptionRate}) = Object [ + "date" .: day + , "stock" .: stock + , "consumption rates" .: consumptionRate + ] -initState :: Reader Pharmacy State -initState = do - pharmacy <- ask - return $ State { +initState :: Pharmacy -> State +initState pharmacy = State { day = toEnum 0 , stock = const 0 <$> pharmacy , consumptionRate = const 0 <$> pharmacy @@ -59,10 +50,8 @@ setDay newDay state@(State {day, stock, consumptionRate}) = state { consume medicineName initialAmount = max 0 $ initialAmount - duration * (consumptionRate ! medicineName) -lastState :: [Event] -> Reader Pharmacy State -lastState events = - foldl applyEvent <$> initState <*> (return $ sortOn date events) - -currentState :: Day -> Pharmacy -> [Event] -> State -currentState targetDay pharmacy events = - setDay targetDay (runReader (lastState events) pharmacy) +stateAt :: Day -> Pharmacy -> [Event] -> State +stateAt targetDay pharmacy events = + setDay targetDay lastState + where + lastState = foldl applyEvent (initState pharmacy) (sortOn date events) diff --git a/src/YAML.hs b/src/YAML.hs new file mode 100644 index 0000000..1fa2f2b --- /dev/null +++ b/src/YAML.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +module YAML ( + (.:) + , Value(..) + , YAML(..) + , encode + ) where + +import Data.List (intercalate) +import Data.Map (Map, toList) + +data Value = Simple String | Array [Value] | Object [(String, Value)] deriving (Show) + +class YAML a where + toYAML :: a -> Value + +instance YAML Value where + toYAML = id + +instance {-# OVERLAPPABLE #-} YAML a => YAML [a] where + toYAML = Array . fmap toYAML + +instance {-# OVERLAPPABLE #-} YAML a => YAML (Map String a) where + toYAML = Object . toList . fmap toYAML + +instance {-# OVERLAPPABLE #-} Show a => YAML a where + toYAML = Simple . show + +instance YAML String where + toYAML = Simple + +encode :: YAML a => a -> String +encode = intercalate "\n" . getLines . toYAML + where + getLines (Simple s) = lines s + getLines (Array l) = concat $ (dashFirst . getLines) <$> l + getLines (Object m) = concat $ keyVal <$> m + dashFirst [] = [] + dashFirst (l:ls) = ("- " ++ l) : ((" " ++) <$> ls) + keyVal (k, Simple s) = + case lines s of + [v] -> [k ++ ": " ++ v] + l -> (k ++ ": |") : (('\t' :) <$> l) + keyVal (k, v) = (k ++ ":") : (('\t' :) <$> getLines v) + +(.:) :: YAML a => String -> a -> (String, Value) +(.:) k v = (k, toYAML v)