{-# Language ImportQualifiedPost, QuasiQuotes #-}
{-|
Module      : Main
Description : Day 7 solution
Copyright   : (c) Eric Mertens, 2018
License     : ISC
Maintainer  : emertens@gmail.com

<https://adventofcode.com/2018/day/7>

-}
{-# Language OverloadedStrings, DeriveTraversable #-}
module Main (main) where

import Advent        (format, ordNub)
import Data.Char     (ord)
import Data.Foldable (toList)
import Data.List     (delete, find, sort, unfoldr)
import Data.Map      (Map)
import Data.Map qualified as Map

-- | Print the answers to day 7
--
-- >>> :main
-- ACBDESULXKYZIMNTFGWJVPOHRQ
-- 980
main :: IO ()
IO ()
main =
  do [(Char, Char)]
input <- [format|2018 7 (Step %c must be finished before step %c can begin.%n)*|]
     let queue :: WorkQueue Char
queue = [Dep Char] -> WorkQueue Char
forall a. Ord a => [Dep a] -> WorkQueue a
newWorkQueue [Char -> Char -> Dep Char
forall a. a -> a -> Dep a
Dep Char
x Char
y | (Char
x,Char
y) <- [(Char, Char)]
input]
     String -> IO ()
putStrLn (WorkQueue Char -> String
forall a. Eq a => WorkQueue a -> [a]
part1 WorkQueue Char
queue)
     Int -> IO ()
forall a. Show a => a -> IO ()
print (WorkQueue Char -> Int
part2 WorkQueue Char
queue)

-- | Given a work queue compute the order that a single elf would complete
-- the tasks.
part1 :: Eq a => WorkQueue a -> [a]
part1 :: forall a. Eq a => WorkQueue a -> [a]
part1 = (WorkQueue a -> Maybe (a, WorkQueue a)) -> WorkQueue a -> [a]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr WorkQueue a -> Maybe (a, WorkQueue a)
forall {a}. Eq a => WorkQueue a -> Maybe (a, WorkQueue a)
go
  where
    go :: WorkQueue a -> Maybe (a, WorkQueue a)
go WorkQueue a
q = do (a
x, WorkQueue a
q') <- WorkQueue a -> Maybe (a, WorkQueue a)
forall {a}. Eq a => WorkQueue a -> Maybe (a, WorkQueue a)
nextTask WorkQueue a
q
              (a, WorkQueue a) -> Maybe (a, WorkQueue a)
forall a. a -> Maybe a
Just (a
x, [a] -> WorkQueue a -> WorkQueue a
forall a. Eq a => [a] -> WorkQueue a -> WorkQueue a
finishTasks [a
x] WorkQueue a
q')

-- | Compute time required to complete all of the work defined by the given
-- work queue given 5 parallel workers.
part2 :: WorkQueue Char -> Int
part2 :: WorkQueue Char -> Int
part2 = Int -> Map Char Int -> WorkQueue Char -> Int
part2' Int
0 Map Char Int
forall k a. Map k a
Map.empty

-- | 'part2' worker loop.
part2' ::
  Int            {- ^ time accumulator                      -} ->
  Map Char Int   {- ^ current tasks with time remaining     -} ->
  WorkQueue Char {- ^ task queue                            -} ->
  Int            {- ^ total time spent to complete all work -}
part2' :: Int -> Map Char Int -> WorkQueue Char -> Int
part2' Int
time Map Char Int
work WorkQueue Char
queue

  -- Workers available and work ready to start
  | Map Char Int -> Int
forall k a. Map k a -> Int
Map.size Map Char Int
work Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
5
  , Just (Char
next, WorkQueue Char
queue') <- WorkQueue Char -> Maybe (Char, WorkQueue Char)
forall {a}. Eq a => WorkQueue a -> Maybe (a, WorkQueue a)
nextTask WorkQueue Char
queue =
      Int -> Map Char Int -> WorkQueue Char -> Int
part2' Int
time (Char -> Int -> Map Char Int -> Map Char Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Char
next (Char -> Int
timeRequired Char
next) Map Char Int
work) WorkQueue Char
queue'

  -- All work complete
  | Map Char Int -> Bool
forall k a. Map k a -> Bool
Map.null Map Char Int
work = Int
time

  -- No work ready to start, make progress on current work
  | Bool
otherwise =
    let step :: Int
step          = Map Char Int -> Int
forall a. Ord a => Map Char a -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum Map Char Int
work
        (Map Char Int
done, Map Char Int
work') = (Int -> Bool) -> Map Char Int -> (Map Char Int, Map Char Int)
forall a k. (a -> Bool) -> Map k a -> (Map k a, Map k a)
Map.partition (Int
0Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==) (Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
step (Int -> Int) -> Map Char Int -> Map Char Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Char Int
work)
        queue' :: WorkQueue Char
queue'        = String -> WorkQueue Char -> WorkQueue Char
forall a. Eq a => [a] -> WorkQueue a -> WorkQueue a
finishTasks (Map Char Int -> String
forall k a. Map k a -> [k]
Map.keys Map Char Int
done) WorkQueue Char
queue
    in Int -> Map Char Int -> WorkQueue Char -> Int
part2' (Int
timeInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
step) ((Int -> Bool) -> Map Char Int -> Map Char Int
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
0) Map Char Int
work') WorkQueue Char
queue'


-- | Compute time required for task by name.
timeRequired :: Char -> Int
timeRequired :: Char -> Int
timeRequired Char
c = Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'A' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
61

------------------------------------------------------------------------

-- | Track a dependency between two items
data Dep a =
  -- | 'depBefore' must be finished before 'depAfter'
  Dep { forall a. Dep a -> a
depBefore, forall a. Dep a -> a
depAfter :: a }
  deriving (ReadPrec [Dep a]
ReadPrec (Dep a)
Int -> ReadS (Dep a)
ReadS [Dep a]
(Int -> ReadS (Dep a))
-> ReadS [Dep a]
-> ReadPrec (Dep a)
-> ReadPrec [Dep a]
-> Read (Dep a)
forall a. Read a => ReadPrec [Dep a]
forall a. Read a => ReadPrec (Dep a)
forall a. Read a => Int -> ReadS (Dep a)
forall a. Read a => ReadS [Dep a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: forall a. Read a => Int -> ReadS (Dep a)
readsPrec :: Int -> ReadS (Dep a)
$creadList :: forall a. Read a => ReadS [Dep a]
readList :: ReadS [Dep a]
$creadPrec :: forall a. Read a => ReadPrec (Dep a)
readPrec :: ReadPrec (Dep a)
$creadListPrec :: forall a. Read a => ReadPrec [Dep a]
readListPrec :: ReadPrec [Dep a]
Read, Int -> Dep a -> ShowS
[Dep a] -> ShowS
Dep a -> String
(Int -> Dep a -> ShowS)
-> (Dep a -> String) -> ([Dep a] -> ShowS) -> Show (Dep a)
forall a. Show a => Int -> Dep a -> ShowS
forall a. Show a => [Dep a] -> ShowS
forall a. Show a => Dep a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Dep a -> ShowS
showsPrec :: Int -> Dep a -> ShowS
$cshow :: forall a. Show a => Dep a -> String
show :: Dep a -> String
$cshowList :: forall a. Show a => [Dep a] -> ShowS
showList :: [Dep a] -> ShowS
Show, (forall a b. (a -> b) -> Dep a -> Dep b)
-> (forall a b. a -> Dep b -> Dep a) -> Functor Dep
forall a b. a -> Dep b -> Dep a
forall a b. (a -> b) -> Dep a -> Dep b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Dep a -> Dep b
fmap :: forall a b. (a -> b) -> Dep a -> Dep b
$c<$ :: forall a b. a -> Dep b -> Dep a
<$ :: forall a b. a -> Dep b -> Dep a
Functor, (forall m. Monoid m => Dep m -> m)
-> (forall m a. Monoid m => (a -> m) -> Dep a -> m)
-> (forall m a. Monoid m => (a -> m) -> Dep a -> m)
-> (forall a b. (a -> b -> b) -> b -> Dep a -> b)
-> (forall a b. (a -> b -> b) -> b -> Dep a -> b)
-> (forall b a. (b -> a -> b) -> b -> Dep a -> b)
-> (forall b a. (b -> a -> b) -> b -> Dep a -> b)
-> (forall a. (a -> a -> a) -> Dep a -> a)
-> (forall a. (a -> a -> a) -> Dep a -> a)
-> (forall a. Dep a -> [a])
-> (forall a. Dep a -> Bool)
-> (forall a. Dep a -> Int)
-> (forall a. Eq a => a -> Dep a -> Bool)
-> (forall a. Ord a => Dep a -> a)
-> (forall a. Ord a => Dep a -> a)
-> (forall a. Num a => Dep a -> a)
-> (forall a. Num a => Dep a -> a)
-> Foldable Dep
forall a. Eq a => a -> Dep a -> Bool
forall a. Num a => Dep a -> a
forall a. Ord a => Dep a -> a
forall m. Monoid m => Dep m -> m
forall a. Dep a -> Bool
forall a. Dep a -> Int
forall a. Dep a -> [a]
forall a. (a -> a -> a) -> Dep a -> a
forall m a. Monoid m => (a -> m) -> Dep a -> m
forall b a. (b -> a -> b) -> b -> Dep a -> b
forall a b. (a -> b -> b) -> b -> Dep a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => Dep m -> m
fold :: forall m. Monoid m => Dep m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Dep a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Dep a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Dep a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> Dep a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> Dep a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Dep a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Dep a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Dep a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Dep a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Dep a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Dep a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> Dep a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> Dep a -> a
foldr1 :: forall a. (a -> a -> a) -> Dep a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Dep a -> a
foldl1 :: forall a. (a -> a -> a) -> Dep a -> a
$ctoList :: forall a. Dep a -> [a]
toList :: forall a. Dep a -> [a]
$cnull :: forall a. Dep a -> Bool
null :: forall a. Dep a -> Bool
$clength :: forall a. Dep a -> Int
length :: forall a. Dep a -> Int
$celem :: forall a. Eq a => a -> Dep a -> Bool
elem :: forall a. Eq a => a -> Dep a -> Bool
$cmaximum :: forall a. Ord a => Dep a -> a
maximum :: forall a. Ord a => Dep a -> a
$cminimum :: forall a. Ord a => Dep a -> a
minimum :: forall a. Ord a => Dep a -> a
$csum :: forall a. Num a => Dep a -> a
sum :: forall a. Num a => Dep a -> a
$cproduct :: forall a. Num a => Dep a -> a
product :: forall a. Num a => Dep a -> a
Foldable, Functor Dep
Foldable Dep
(Functor Dep, Foldable Dep) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> Dep a -> f (Dep b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Dep (f a) -> f (Dep a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Dep a -> m (Dep b))
-> (forall (m :: * -> *) a. Monad m => Dep (m a) -> m (Dep a))
-> Traversable Dep
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Dep (m a) -> m (Dep a)
forall (f :: * -> *) a. Applicative f => Dep (f a) -> f (Dep a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Dep a -> m (Dep b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Dep a -> f (Dep b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Dep a -> f (Dep b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Dep a -> f (Dep b)
$csequenceA :: forall (f :: * -> *) a. Applicative f => Dep (f a) -> f (Dep a)
sequenceA :: forall (f :: * -> *) a. Applicative f => Dep (f a) -> f (Dep a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Dep a -> m (Dep b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Dep a -> m (Dep b)
$csequence :: forall (m :: * -> *) a. Monad m => Dep (m a) -> m (Dep a)
sequence :: forall (m :: * -> *) a. Monad m => Dep (m a) -> m (Dep a)
Traversable)

-- | Track remaining tasks and dependencies between tasks.
data WorkQueue a = WorkQueue [Dep a] [a]

-- | Construct a new work queue given the task dependencies. Task IDs
-- are computed by checking the IDs mentioned in the dependencies.
newWorkQueue :: Ord a => [Dep a] -> WorkQueue a
newWorkQueue :: forall a. Ord a => [Dep a] -> WorkQueue a
newWorkQueue [Dep a]
deps = [Dep a] -> [a] -> WorkQueue a
forall a. [Dep a] -> [a] -> WorkQueue a
WorkQueue [Dep a]
deps [a]
remaining
  where
    remaining :: [a]
remaining = [a] -> [a]
forall a. Ord a => [a] -> [a]
ordNub ([a] -> [a]
forall a. Ord a => [a] -> [a]
sort ((Dep a -> [a]) -> [Dep a] -> [a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Dep a -> [a]
forall a. Dep a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [Dep a]
deps))

-- | Find the next task available to be started and remove it from
-- the work queue.
nextTask :: Eq a => WorkQueue a -> Maybe (a, WorkQueue a)
nextTask :: forall {a}. Eq a => WorkQueue a -> Maybe (a, WorkQueue a)
nextTask (WorkQueue [Dep a]
deps [a]
remaining) =
  do a
next <- (a -> Bool) -> [a] -> Maybe a
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (Dep a -> a) -> [Dep a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map Dep a -> a
forall a. Dep a -> a
depAfter [Dep a]
deps) [a]
remaining
     (a, WorkQueue a) -> Maybe (a, WorkQueue a)
forall a. a -> Maybe a
Just (a
next, [Dep a] -> [a] -> WorkQueue a
forall a. [Dep a] -> [a] -> WorkQueue a
WorkQueue [Dep a]
deps (a -> [a] -> [a]
forall a. Eq a => a -> [a] -> [a]
delete a
next [a]
remaining))

-- | Mark a list of tasks as completed so that tasks depending on them
-- can be started.
finishTasks :: Eq a => [a] -> WorkQueue a -> WorkQueue a
finishTasks :: forall a. Eq a => [a] -> WorkQueue a -> WorkQueue a
finishTasks [a]
tasks (WorkQueue [Dep a]
deps [a]
remaining) = [Dep a] -> [a] -> WorkQueue a
forall a. [Dep a] -> [a] -> WorkQueue a
WorkQueue [Dep a]
deps' [a]
remaining
  where
    deps' :: [Dep a]
deps' = (Dep a -> Bool) -> [Dep a] -> [Dep a]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Dep a
x -> Dep a -> a
forall a. Dep a -> a
depBefore Dep a
x a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [a]
tasks) [Dep a]
deps