Day 16
This commit is contained in:
Christian
214
src/Days/D16.hs
Normal file
214
src/Days/D16.hs
Normal file
@@ -0,0 +1,214 @@
|
||||
{-# LANGUAGE ImportQualifiedPost #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module Days.D16 where
|
||||
|
||||
import Common
|
||||
import Data.Char (isAsciiUpper)
|
||||
import Data.List (foldl', sortOn)
|
||||
import Data.Map (Map)
|
||||
import Data.Map qualified as Map
|
||||
import Data.Maybe (fromJust, fromMaybe, isJust)
|
||||
import Data.Ord (Down (..))
|
||||
import Data.Set (Set)
|
||||
import Data.Set qualified as Set
|
||||
import Data.Text (Text)
|
||||
import Data.Tuple (swap)
|
||||
import Data.Vector (Vector)
|
||||
import Data.Vector qualified as Vector
|
||||
import Parse
|
||||
import Text.Megaparsec (sepBy, takeWhile1P, (<|>))
|
||||
import Text.Megaparsec.Char (space)
|
||||
import Text.Megaparsec.Char.Lexer qualified as Lexer
|
||||
|
||||
type ValveName = Text
|
||||
|
||||
parser :: Parser (Map ValveName Int, Map ValveName [ValveName])
|
||||
parser = makeMaps <$> someLines nodeDescription
|
||||
where
|
||||
symbol = Lexer.symbol space
|
||||
lexeme = Lexer.lexeme space
|
||||
|
||||
valve :: Parser Text
|
||||
valve = takeWhile1P Nothing isAsciiUpper
|
||||
|
||||
nodeDescription =
|
||||
(,,)
|
||||
<$ symbol "Valve"
|
||||
<*> lexeme valve
|
||||
<* symbol "has flow rate="
|
||||
<*> number
|
||||
<* symbol ";"
|
||||
<* ( symbol "tunnels lead to valves"
|
||||
<|> symbol "tunnel leads to valve"
|
||||
)
|
||||
<*> sepBy valve (symbol ",")
|
||||
|
||||
makeMaps :: [(Text, Int, [Text])] -> (Map Text Int, Map Text [Text])
|
||||
makeMaps intermediate =
|
||||
let (valve, rate, connections) = unzip3 intermediate
|
||||
in ( Map.fromList (zip valve rate),
|
||||
Map.fromList (zip valve connections)
|
||||
)
|
||||
|
||||
floydWarshall :: (Ord a) => Map a [a] -> Map (a, a) Int
|
||||
floydWarshall m =
|
||||
let keys = Map.keys m
|
||||
in foldl'
|
||||
( \acc (k, i, j) ->
|
||||
Map.alter
|
||||
( let newPath =
|
||||
do
|
||||
dist_i_k <- Map.lookup (i, k) acc
|
||||
dist_k_j <- Map.lookup (k, j) acc
|
||||
return $ dist_i_k + dist_k_j
|
||||
in \case
|
||||
Nothing -> newPath
|
||||
Just v -> Just $ case newPath of
|
||||
Nothing -> v
|
||||
Just newPath_ -> min v newPath_
|
||||
)
|
||||
(i, j)
|
||||
acc
|
||||
)
|
||||
(Map.fromList [((a, b), 1) | a <- keys, b <- fromMaybe [] $ Map.lookup a m])
|
||||
[(k, i, j) | k <- keys, i <- keys, j <- keys]
|
||||
|
||||
data Network = Network
|
||||
{ rates :: Map ValveName Int,
|
||||
nextBest :: Map ValveName (Vector (ValveName, Int))
|
||||
}
|
||||
|
||||
preProcess ::
|
||||
Map ValveName Int ->
|
||||
Map ValveName [ValveName] ->
|
||||
Network
|
||||
preProcess rates network =
|
||||
let distances = floydWarshall network
|
||||
possibleStops = Map.filterWithKey (\k v -> v > 0 || k == "AA") rates
|
||||
possibleStopsV = Vector.fromList . Map.toList $ possibleStops
|
||||
nextBest =
|
||||
Map.fromList
|
||||
[ ( from,
|
||||
Vector.fromList
|
||||
. map snd
|
||||
. sortOn (Down . fst)
|
||||
$ [ (rate, (to, dist + 1))
|
||||
| (to, rate) <- Vector.toList possibleStopsV,
|
||||
rate > 0,
|
||||
let maybeDist = Map.lookup (from, to) distances,
|
||||
isJust maybeDist,
|
||||
let dist = fromJust maybeDist
|
||||
]
|
||||
)
|
||||
| (from, _) <- Vector.toList possibleStopsV
|
||||
]
|
||||
in Network
|
||||
{ rates = possibleStops,
|
||||
nextBest = nextBest
|
||||
}
|
||||
|
||||
data SearchState = SearchState
|
||||
{ pressure :: Int,
|
||||
opened :: Set ValveName,
|
||||
pos :: (ValveName, ValveName),
|
||||
time :: (Int, Int)
|
||||
}
|
||||
|
||||
maximizePressure ::
|
||||
Int ->
|
||||
Bool ->
|
||||
ValveName ->
|
||||
Network ->
|
||||
Int
|
||||
maximizePressure deadline withElephant start (Network {..}) =
|
||||
go
|
||||
0
|
||||
SearchState
|
||||
{ pressure = 0,
|
||||
opened = Set.empty,
|
||||
pos = (start, start),
|
||||
time = (deadline, if withElephant then deadline else 0)
|
||||
}
|
||||
where
|
||||
go :: Int -> SearchState -> Int
|
||||
go best searcher =
|
||||
let nextStates = branch searcher
|
||||
in if null nextStates
|
||||
then pressure searcher
|
||||
else
|
||||
foldl'
|
||||
( \best_ nextSearcher ->
|
||||
if bound nextSearcher > best_
|
||||
then max (go best_ nextSearcher) best_
|
||||
else best_
|
||||
)
|
||||
best
|
||||
nextStates
|
||||
|
||||
branch :: SearchState -> [SearchState]
|
||||
branch SearchState {..} =
|
||||
[ let f = if nextTime < snd time then swap else id
|
||||
in SearchState
|
||||
{ pressure = pressure + rate * nextTime,
|
||||
opened = Set.insert nextPos opened,
|
||||
pos = f (nextPos, snd pos),
|
||||
time = f (nextTime, snd time)
|
||||
}
|
||||
| (nextPos, dist) <-
|
||||
maybe [] Vector.toList (Map.lookup (fst pos) nextBest),
|
||||
fst time > dist,
|
||||
not $ Set.member nextPos opened,
|
||||
let nextTime = fst time - dist,
|
||||
let rate = fromJust (Map.lookup nextPos rates)
|
||||
]
|
||||
|
||||
heuristic :: Vector (Vector (ValveName, Int, Int))
|
||||
heuristic =
|
||||
Vector.fromList
|
||||
[ Vector.reverse
|
||||
. Vector.fromList
|
||||
. sortOn (\(_, min_dist, rate) -> (time - min_dist) * rate)
|
||||
$ [ (valve, min_dist, rate)
|
||||
| (valve, rate) <- Map.toList rates,
|
||||
let min_dist =
|
||||
minimum
|
||||
. Vector.map snd
|
||||
. fromJust
|
||||
$ Map.lookup valve nextBest,
|
||||
time > min_dist
|
||||
]
|
||||
| time <- [0 .. deadline]
|
||||
]
|
||||
|
||||
bound :: SearchState -> Int
|
||||
bound SearchState {..} = uncurry (go opened) time pressure
|
||||
where
|
||||
go opened max_t min_t bound =
|
||||
case Vector.toList
|
||||
. Vector.filter (\(valve, _, _) -> not $ Set.member valve opened)
|
||||
$ (heuristic Vector.! max_t) of
|
||||
[] -> bound
|
||||
((valveId, min_dist, flow) : _) ->
|
||||
let max_t' = max_t - min_dist
|
||||
bound' = bound + flow * max_t'
|
||||
min_t' = min min_t max_t'
|
||||
max_t'' = max min_t max_t'
|
||||
opened' = Set.insert valveId opened
|
||||
in go opened' max_t'' min_t' bound'
|
||||
|
||||
part1 :: Network -> Int
|
||||
part1 = maximizePressure 30 False "AA"
|
||||
|
||||
part2 :: Network -> Int
|
||||
part2 = maximizePressure 26 True "AA"
|
||||
|
||||
day :: Day
|
||||
day =
|
||||
parsecDay
|
||||
(uncurry preProcess <$> parser)
|
||||
( definitive . part1,
|
||||
definitive . part2
|
||||
)
|
||||
@@ -27,6 +27,7 @@ import Days.D12 qualified as D12
|
||||
import Days.D13 qualified as D13
|
||||
import Days.D14 qualified as D14
|
||||
import Days.D15 qualified as D15
|
||||
import Days.D16 qualified as D16
|
||||
|
||||
import Data.ByteString.Char8 qualified as BS
|
||||
import Data.Text.IO qualified as T
|
||||
@@ -54,4 +55,5 @@ days =
|
||||
, [D13.day]
|
||||
, [D14.day]
|
||||
, [D15.day]
|
||||
, [D16.day]
|
||||
]
|
||||
|
||||
Reference in New Issue
Block a user