src/advent07/advent07.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2
   3 import Data.List
   4 import Data.Char (ord)
   5
   6 import Data.Text (Text)
   7 import qualified Data.Text.IO as TIO
   8
   9 import Data.Void (Void)
  10
  11 import Text.Megaparsec
  12 import Text.Megaparsec.Char
  13 import qualified Text.Megaparsec.Char.Lexer as L
  14 import qualified Control.Applicative as CA
  15
  16 import Data.Map.Strict ((!))
  17 import qualified Data.Map.Strict as M
  18 import qualified Data.Set as S
  19
  20 type Job = Char
  21 type Link = (Job, Job)
  22 type Preconditions = S.Set Job
  23 type Schedule = M.Map Job Preconditions
  24 data Worker = Idle | BusyUntil Job Int deriving (Show, Eq)
  25
  26 workerJob (BusyUntil job _) = job
  27 workerJob Idle = '\xff'
  28
  29 workerFinishTime (BusyUntil _ time) = time
  30 workerFinishTime Idle = 100000
  31
  32 main :: IO ()
  33 main = do
  34         text <- TIO.readFile "data/advent07.txt"
  35         let links = successfulParse text
  36         -- print links
  37         let schedule = buildSchedule links
  38         -- print schedule
  39         -- print $ candidates schedule
  40         putStrLn $ part1 schedule
  41         print $ part2 schedule
  42
  43
  44 part1 schedule = unfoldr jobStep schedule
  45
  46 part2 schedule = last $ unfoldr jobStepTimed (schedule, initialWorkers)
  47     where idleWorkers = take 5 $ repeat Idle
  48           initialWorkers = employWorkers idleWorkers 0 schedule
  49
  50
  51 ensureKnown :: Job -> Schedule -> Schedule
  52 ensureKnown j s
  53     | j `M.member` s = s
  54     | otherwise      = M.insert j S.empty s
  55
  56 includeLink :: Schedule -> Link -> Schedule
  57 includeLink schedule (pre, post) = M.insert post conditions' schedule''
  58     where schedule' = ensureKnown pre schedule
  59           schedule'' = ensureKnown post schedule'
  60           conditions = schedule''!post
  61           conditions' = S.insert pre conditions
  62
  63 buildSchedule :: [Link] -> Schedule
  64 buildSchedule = foldl' includeLink M.empty
  65
  66 candidates :: Schedule -> Schedule
  67 candidates = M.filter S.null
  68
  69 currentJob :: Schedule -> Job
  70 currentJob = head . availableJobs
  71
  72 availableJobs :: Schedule -> [Job] -- note that this sorts the keys for us
  73 availableJobs = M.keys . candidates
  74
  75 performJob :: Job -> Schedule -> Schedule
  76 performJob job schedule = schedule''
  77     where schedule' = M.delete job schedule
  78           schedule'' = M.map (\p -> S.delete job p) schedule'
  79
  80 jobStep :: Schedule -> Maybe (Job, Schedule)
  81 jobStep schedule
  82     | M.null schedule = Nothing
  83     | otherwise = Just (job, schedule')
  84     where job = currentJob schedule
  85           schedule' = performJob job schedule
  86
  87
  88 jobDuration :: Job -> Int
  89 jobDuration job = 61 + ord(job) - ord('A')
  90 -- jobDuration job = 1 + ord(job) - ord('A')
  91
  92
  93 startTimedJob :: Job -> Int -> Worker
  94 startTimedJob job startTime = BusyUntil job (startTime + jobDuration job)
  95
  96
  97 employWorkers :: [Worker] -> Int -> Schedule -> [Worker]
  98 employWorkers workers time schedule = take (length workers) (busyWorkers ++ newWorkers ++ repeat Idle)
  99     where idleWorkerCount = length $ filter (== Idle) workers
 100           busyWorkers = filter (/= Idle) workers
 101           currentJobs = map workerJob busyWorkers
 102           startingJobs = take idleWorkerCount $ filter (\j -> j `notElem` currentJobs) $ availableJobs schedule
 103           newWorkers = map (\job -> startTimedJob job time) startingJobs
 104 -- employWorkers workers _ _ = workers
 105
 106 completeTimedJob :: Schedule -> Job -> Schedule
 107 completeTimedJob schedule job = schedule''
 108     where schedule' = M.delete job schedule
 109           schedule'' = M.map (\p -> S.delete job p) schedule'
 110
 111
 112 earliestFinishTime :: [Worker] -> Int
 113 earliestFinishTime workers = minimum $ map workerFinishTime workers
 114
 115
 116 finishJobs :: [Worker] -> Schedule -> ([Worker], Schedule, Int)
 117 finishJobs workers schedule = (continuingWorkers ++ idleWorkers, schedule', time)
 118     where time = earliestFinishTime workers
 119           (finishingWorkers, continuingWorkers) = partition (\w -> workerFinishTime w == time) workers
 120           schedule' = foldl' completeTimedJob schedule $ map workerJob finishingWorkers
 121           idleWorkers = map fst $ zip (repeat Idle) finishingWorkers
 122
 123
 124 jobStepTimed :: (Schedule, [Worker]) -> Maybe (Int, (Schedule, [Worker]))
 125 jobStepTimed (schedule, workers)
 126     | M.null schedule = Nothing
 127     | otherwise = Just (time, (schedule', workers''))
 128     where (workers', schedule', time) = finishJobs workers schedule
 129           workers'' = employWorkers workers' time schedule'
 130
 131
 132
 133 -- Parse the input file
 134
 135 type Parser = Parsec Void Text
 136
 137 sc :: Parser ()
 138 sc = L.space (skipSome spaceChar) CA.empty CA.empty
 139
 140 -- lexeme  = L.lexeme sc
 141 -- integer = lexeme L.decimal
 142 symb = L.symbol sc
 143
 144 prefixP = symb "Step"
 145 infixP = symb " must be finished before step"
 146 suffixP = symb " can begin."
 147
 148 linkFileP = many linkP
 149
 150 linkP = pairify <$> prefixP <*> upperChar <* infixP <*> upperChar <* suffixP
 151     where pairify _ a b = (a, b)
 152
 153 successfulParse :: Text -> [Link]
 154 successfulParse input =
 155         case parse linkFileP "input" input of
 156                 Left  _error -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err
 157                 Right links -> links