module AOC.Challenge.Day24 (
day24a
, day24b
) where
import AOC.Common (Point, cardinalNeighbsSet, parseAsciiMap, firstRepeated, (!!!), Dir(..))
import AOC.Solver ((:~>)(..), dyno_)
import Control.DeepSeq (NFData)
import Data.Finite (Finite, finites)
import Data.Semigroup (Min(..), Max(..), Sum(..))
import Data.Set (Set)
import GHC.Generics (Generic)
import Linear.V2 (V2(..))
import qualified Data.Map as M
import qualified Data.Set as S
allPoints :: Set Point
allPoints = S.fromList $ V2 <$> [0..4] <*> [0..4]
stepWith
:: Ord a
=> (Set a -> Set a)
-> (a -> Set a)
-> Set a
-> [Set a]
stepWith universe neighbs = iterate go
where
go s0 = flip S.filter (universe s0) $ \p ->
let n = S.size $ neighbs p `S.intersection` s0
in if p `S.member` s0
then n == 1
else n == 1 || n == 2
day24a :: Set Point :~> Set Point
day24a = MkSol
{ sParse = Just . parseMap
, sShow = show . getSum . foldMap (Sum . biodiversity)
, sSolve = firstRepeated . stepWith (const allPoints) cardinalNeighbsSet
}
where
biodiversity :: Point -> Int
biodiversity (V2 x y) = 2 ^ (y * 5 + x)
type P5 = V2 (Finite 5)
mkP5 :: Finite 5 -> Finite 5 -> Maybe P5
mkP5 2 2 = Nothing
mkP5 x y = Just (V2 x y)
data Loc = L
{ lLevel :: !Int
, lPoint :: !P5
}
deriving (Eq, Ord, Show, Generic)
instance NFData Loc
stepLoc :: Loc -> Dir -> [Loc]
stepLoc (L n p@(V2 x y)) = \case
North -> case p of
V2 2 3 -> L (n + 1) . (`V2` 4) <$> finites
V2 _ 0 -> [L (n - 1) (V2 2 1)]
_ -> [L n (V2 x (y - 1))]
East -> case p of
V2 1 2 -> L (n + 1) . V2 0 <$> finites
V2 4 _ -> [L (n - 1) (V2 3 2)]
_ -> [L n (V2 (x + 1) y)]
South -> case p of
V2 2 1 -> L (n + 1) . (`V2` 0) <$> finites
V2 _ 4 -> [L (n - 1) (V2 2 3)]
_ -> [L n (V2 x (y + 1))]
West -> case p of
V2 3 2 -> L (n + 1) . V2 4 <$> finites
V2 0 _ -> [L (n - 1) (V2 1 2)]
_ -> [L n (V2 (x - 1) y)]
day24b :: Set Loc :~> Set Loc
day24b = MkSol
{ sParse = Just . S.map (L 0 . fmap fromIntegral) . parseMap
, sShow = show . S.size
, sSolve = Just . (!!! dyno_ "steps" 200) . stepWith getUniverse getNeighbs
}
where
getNeighbs p = S.fromList $ foldMap (stepLoc p) [North ..]
getUniverse s = oldLocs <> zoomOut
where
oldLocs = S.fromList
[ L n p
| n <- [mn .. mx + 1]
, Just p <- mkP5 <$> finites <*> finites
]
zoomOut = S.fromList
[ L (mn - 1) p
| Just p <- mkP5 <$> [1..3] <*> [1..3]
]
(Min mn, Max mx) = foldMap (\(lLevel->l) -> (Min l, Max l)) . S.toList $ s
parseMap :: String -> Set Point
parseMap = M.keysSet . M.filter (== '#') . parseAsciiMap Just