Day 19
This commit is contained in:
Christian
203
src/Days/D19.hs
Normal file
203
src/Days/D19.hs
Normal file
@@ -0,0 +1,203 @@
|
||||
{-# LANGUAGE ImportQualifiedPost #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module Days.D19 where
|
||||
|
||||
import Common
|
||||
import Data.Char (isDigit)
|
||||
import Data.Functor ((<&>))
|
||||
import Data.Heap (MaxPrioHeap)
|
||||
import Data.Heap qualified as Heap
|
||||
import Data.Vector (Vector)
|
||||
import Data.Vector qualified as Vector
|
||||
import Data.Vector.Unboxed (Unbox)
|
||||
import Data.Vector.Unboxed qualified as UnVector
|
||||
import Parse
|
||||
import Text.Megaparsec (sepEndBy1, takeWhileP)
|
||||
|
||||
data Material = Ore | Clay | Obsidian | Geode
|
||||
deriving (Enum, Ord, Eq)
|
||||
|
||||
materials :: [Material]
|
||||
materials = [Ore, Clay, Obsidian, Geode]
|
||||
|
||||
newtype Blueprint = Bp
|
||||
{ costs :: Vector (UnVector.Vector Int)
|
||||
}
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- e.g. Blueprint 2: Each ore robot costs 2 ore. Each clay robot costs 2 ore. Each obsidian robot costs 2 ore and 15 clay. Each geode robot costs 2 ore and 7 obsidian.
|
||||
parser :: Parser [Blueprint]
|
||||
parser = someLines blueprint
|
||||
where
|
||||
numbersInLine :: Parser [Int]
|
||||
numbersInLine =
|
||||
takeWhileP (Just "numbersInLine") (not . isDigit)
|
||||
*> sepEndBy1
|
||||
number
|
||||
( takeWhileP
|
||||
(Just "numbersInLine")
|
||||
(\c -> c /= '\n' && not (isDigit c))
|
||||
)
|
||||
blueprint =
|
||||
numbersInLine
|
||||
<&> ( \case
|
||||
[_, a, b, c, d, e, f] ->
|
||||
Bp
|
||||
{ costs =
|
||||
Vector.fromList
|
||||
[ UnVector.fromList [a, 0, 0, 0],
|
||||
UnVector.fromList [b, 0, 0, 0],
|
||||
UnVector.fromList [c, d, 0, 0],
|
||||
UnVector.fromList [e, 0, f, 0]
|
||||
]
|
||||
}
|
||||
_ -> error "Malformed blueprint specification."
|
||||
)
|
||||
|
||||
cost :: Blueprint -> Material -> UnVector.Vector Int
|
||||
cost bp material = costs bp Vector.! fromEnum material
|
||||
|
||||
data SearchState = SS
|
||||
{ resources :: UnVector.Vector Int,
|
||||
robots :: UnVector.Vector Int,
|
||||
time :: Int
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
(@) :: (Unbox a, Enum b) => UnVector.Vector a -> b -> a
|
||||
(@) = (. fromEnum) . (UnVector.!)
|
||||
|
||||
(<=@) :: (Ord a, Unbox a) => UnVector.Vector a -> UnVector.Vector a -> Bool
|
||||
v1 <=@ v2 = UnVector.and $ UnVector.zipWith (<=) v1 v2
|
||||
|
||||
(+@) :: (Num a, Unbox a) => UnVector.Vector a -> UnVector.Vector a -> UnVector.Vector a
|
||||
(+@) = UnVector.zipWith (+)
|
||||
|
||||
simulate :: Int -> Blueprint -> Int
|
||||
simulate deadline bp =
|
||||
go 0 $ Heap.singleton (upper initial, initial)
|
||||
|
||||
where
|
||||
initial :: SearchState
|
||||
initial =
|
||||
SS
|
||||
{ resources = UnVector.fromList [0, 0, 0, 0],
|
||||
robots = UnVector.fromList [1, 0, 0, 0],
|
||||
time = deadline
|
||||
}
|
||||
|
||||
limits :: UnVector.Vector Int
|
||||
limits =
|
||||
UnVector.fromList
|
||||
[ maximum
|
||||
[ cost bp other @ m
|
||||
| other <- filter (/= m) materials
|
||||
]
|
||||
| m <- materials
|
||||
]
|
||||
|
||||
prereq Geode = [Ore, Obsidian]
|
||||
prereq Obsidian = [Ore, Clay]
|
||||
prereq Clay = [Ore]
|
||||
prereq Ore = [Ore]
|
||||
|
||||
purchase :: Material -> UnVector.Vector Int -> UnVector.Vector Int
|
||||
purchase = UnVector.zipWith subtract . cost bp
|
||||
|
||||
addRobot :: Material -> UnVector.Vector Int -> UnVector.Vector Int
|
||||
addRobot m r = r UnVector.// [(fromEnum m, r @ m + 1)]
|
||||
|
||||
build :: SearchState -> Material -> SearchState
|
||||
build SS {..} kind =
|
||||
let materialsNeeded = cost bp kind
|
||||
timeNeededFor material =
|
||||
if (robots @ material == 0)
|
||||
|| (resources @ material >= materialsNeeded @ material)
|
||||
then 0
|
||||
else
|
||||
1
|
||||
+ ( (materialsNeeded @ material - resources @ material - 1)
|
||||
`div` (robots @ material)
|
||||
)
|
||||
stepsNeeded = 1 + maximum (map timeNeededFor materials)
|
||||
resources' =
|
||||
(+@ resources)
|
||||
. UnVector.map (stepsNeeded *)
|
||||
$ robots
|
||||
in SS
|
||||
{ resources = purchase kind resources',
|
||||
robots = addRobot kind robots,
|
||||
time = time - stepsNeeded
|
||||
}
|
||||
|
||||
nexts :: SearchState -> [SearchState]
|
||||
nexts ss@SS {robots} =
|
||||
[ next
|
||||
| m <- materials,
|
||||
m == Geode || robots @ m < limits @ m,
|
||||
and [robots @ p > 0 | p <- prereq m],
|
||||
let next = build ss m,
|
||||
time next > 0
|
||||
]
|
||||
|
||||
-- upper SS{..} = resources @ Geode + time * robots @ Geode + time * (time - 1)
|
||||
upper :: SearchState -> Int
|
||||
upper ss =
|
||||
((@ Geode) . resources)
|
||||
. head
|
||||
. dropWhile ((> 0) . time)
|
||||
$ iterate
|
||||
( \SS {..} ->
|
||||
let newRobots =
|
||||
UnVector.fromList $
|
||||
map
|
||||
( \m ->
|
||||
if cost bp m <=@ resources
|
||||
then 1
|
||||
else 0
|
||||
)
|
||||
materials
|
||||
in SS
|
||||
{ resources = resources +@ robots,
|
||||
robots = robots +@ newRobots,
|
||||
time = time - 1
|
||||
}
|
||||
)
|
||||
ss
|
||||
|
||||
go :: Int -> MaxPrioHeap Int SearchState -> Int
|
||||
go maxFound_ heap_ =
|
||||
case Heap.view heap_ of
|
||||
Nothing -> maxFound_
|
||||
Just ((bestUpper, bestState), heap) ->
|
||||
let maxFound =
|
||||
max
|
||||
maxFound_
|
||||
( (resources bestState @ Geode)
|
||||
+ (time bestState * robots bestState @ Geode)
|
||||
)
|
||||
in if bestUpper <= maxFound_
|
||||
then maxFound_
|
||||
else
|
||||
foldl
|
||||
( \best next ->
|
||||
let nextUpper = upper next
|
||||
in if nextUpper <= best
|
||||
then best
|
||||
else go best (Heap.insert (nextUpper, next) heap)
|
||||
)
|
||||
maxFound
|
||||
(nexts bestState)
|
||||
|
||||
part1 :: [Blueprint] -> Int
|
||||
part1 = sum . zipWith (*) [1 ..] . map (simulate 24)
|
||||
|
||||
part2 :: [Blueprint] -> Int
|
||||
part2 = product . map (simulate 32) . take 3
|
||||
|
||||
day :: Day
|
||||
day = parsecDay parser (definitive . part1, definitive . part2)
|
||||
Reference in New Issue
Block a user