From c1074a1a5457ba49fc3257add6e2159309badb75 Mon Sep 17 00:00:00 2001 From: Neil Smith Date: Tue, 2 Jan 2024 12:08:37 +0000 Subject: [PATCH] Day 23 part 2 --- advent-of-code23.cabal | 3 +- advent23/Main.hs | 106 ++++++++++++++++++++++++++++++----------- 2 files changed, 79 insertions(+), 30 deletions(-) diff --git a/advent-of-code23.cabal b/advent-of-code23.cabal index ec2ef49..ff49604 100644 --- a/advent-of-code23.cabal +++ b/advent-of-code23.cabal @@ -230,5 +230,4 @@ executable advent22 executable advent23 import: common-extensions, build-directives main-is: advent23/Main.hs - build-depends: linear, containers - \ No newline at end of file + build-depends: linear, containers, lens diff --git a/advent23/Main.hs b/advent23/Main.hs index b811082..457f42b 100644 --- a/advent23/Main.hs +++ b/advent23/Main.hs @@ -1,77 +1,126 @@ --- Writeup at https://work.njae.me.uk/2023/12/29/advent-of-code-2023-day-21/ +-- Writeup at https://work.njae.me.uk/2024/01/02/advent-of-code-2023-day-23/ + +import qualified Debug.Trace as DT import AoC -import Linear (V2(..), (^+^)) +import Linear -- (V2(..), (^+^)) import qualified Data.Set as S import qualified Data.Map as M +import Control.Lens +import Data.List (foldl') data Slide = SlideLeft | SlideRight | SlideUp | SlideDown deriving (Show, Eq) type Position = V2 Int -- r, c + +_r, _c :: Lens' (V2 Int) Int +_r = _x +_c = _y + type Grid = S.Set Position type Slides = M.Map Position Slide +data CompressedPath = CPath { _nextPos :: Position, _pathLen :: Int } + deriving (Show, Eq) +makeLenses ''CompressedPath + +type CompressedMap = M.Map Position [CompressedPath] + + main :: IO () -main = +main = do dataFileName <- getDataFileName text <- readFile dataFileName let (forest, slides, start, end) = mkGrid text - -- print forest - -- print slides - -- print start - -- print end - -- print $ searchStep slides forest [start ^+^ (V2 1 0), start] - -- let paths = search slides forest end [] [[start ^+^ (V2 1 0), start]] - -- print $ fmap length paths print $ part1 slides forest start end + print $ part2 slides forest start end -part1 slides forest start end = (maximum $ fmap length paths) - 1 - where paths = search slides forest end [] [[start ^+^ (V2 1 0), start]] +part1, part2 :: Slides -> Grid -> Position -> Position -> Int +part1 slides forest start end = maximum $ fmap (pathLength cMap) paths + where cMap = compress slides forest start end + paths = searchCompressed cMap end [] [[start]] +part2 _ forest start end = maximum $ fmap (pathLength cMap) paths + where cMap = compress M.empty forest start end + paths = searchCompressed cMap end [] [[start]] adjacents :: Position -> Slides -> Grid -> [Position] -adjacents here slides walls = filter (`S.notMember` walls) $ fmap (^+^ here) deltas +adjacents here slides forest = filter (`S.notMember` forest) $ fmap (here ^+^) deltas where deltas = case M.lookup here slides of Nothing -> [ V2 0 1, V2 1 0, V2 0 (-1), V2 (-1) 0 ] Just SlideLeft -> [ V2 0 (-1) ] Just SlideRight -> [ V2 0 1 ] Just SlideUp -> [ V2 (-1) 0 ] Just SlideDown -> [ V2 1 0 ] - + searchStep :: Slides -> Grid -> [Position] -> [[Position]] searchStep _ _ [] = [] searchStep slides forest path@(here:rest) = fmap (:path) valids where nexts = adjacents here slides forest valids = filter (`notElem` rest) nexts - -search :: Slides -> Grid -> Position -> [[Position]] -> [[Position]] -> [[Position]] +search :: Slides -> Grid -> [Position] -> CompressedMap -> [[Position]] -> CompressedMap search _ _ _ foundPaths [] = foundPaths -search slides forest goal foundPaths (current:agenda) - | head current == goal = search slides forest goal (current:foundPaths) agenda - | otherwise = search slides forest goal foundPaths (agenda ++ extendeds) +search slides forest goals foundPaths (current:agenda) + | head current `elem` goals = search slides forest goals foundPaths' agenda + | otherwise = search slides forest goals foundPaths (agenda ++ extendeds) where extendeds = searchStep slides forest current + origin = last current + foundPaths' = if origin == head current then foundPaths + else M.adjust (cp :) origin foundPaths + cp = CPath (head current) (length current - 1) + +-- collapsing the map + +interestingPoints :: Slides -> Grid -> Position -> Position -> CompressedMap +interestingPoints slides forest start end = M.fromList [(p, []) | p <- pointsSE] + where Just minR = minimumOf (folded . _r) forest + Just maxR = maximumOf (folded . _r) forest + Just minC = minimumOf (folded . _c) forest + Just maxC = maximumOf (folded . _c) forest + points = [ V2 r c | r <- [(minR + 2)..(maxR - 2)] + , c <- [(minC + 1)..(maxC - 1)] + , (V2 r c) `S.notMember` forest + , (length $ adjacents (V2 r c) slides forest) > 2 + ] + pointsSE = start : end : points + +compress :: Slides -> Grid -> Position -> Position -> CompressedMap +compress slides forest start end = foldl' go compressed0 iPoints + where compressed0 = interestingPoints slides forest start end + iPoints = M.keys compressed0 + go com here = search slides forest iPoints com $ fmap (: [here]) $ adjacents here slides forest + + +searchCompressed :: CompressedMap -> Position -> [[Position]] -> [[Position]] -> [[Position]] +-- searchCompressed _ _ _ (c:_) _ | DT.trace (show c) False = undefined +searchCompressed _ _ found [] = found +searchCompressed map goal found (current:agenda) + | head current == goal = searchCompressed map goal (current:found) agenda + | otherwise = searchCompressed map goal found (nextPositions ++ agenda) + where neighbours0 = map M.! (head current) + neighbours = neighbours0 ^.. folded . filtered ((`notElem` current) . _nextPos) + nextPositions = fmap ((: current) . _nextPos) neighbours +pathLength :: CompressedMap -> [Position] -> Int +pathLength map ps = sum $ zipWith (stepLength map) ps $ tail ps --- showGrid :: Grid -> (Position, Position) -> Grid -> String --- showGrid rocks bounds cells = unlines $ intercalate [" "] $ chunksOf 7 $ fmap (showRow rocks bounds cells) [-28..34] --- where showRow rocks bounds cells r = intercalate " " $ chunksOf 7 $ fmap ((showCell rocks bounds cells) . V2 r) [-28..34] --- showCell rocks bounds cells here --- | not $ notAtRock rocks bounds here = '#' --- | here `S.member` cells = 'O' --- | otherwise = '.' +stepLength :: CompressedMap -> Position -> Position -> Int +stepLength map here there = + -- head $ (map M.! there) ^.. folded . filtered ((== here) . _nextPos) . pathLen + head $ (map M.! there) ^.. folded . filteredBy (nextPos . only here) . pathLen -- reading the map mkGrid :: String -> (Grid, Slides, Position, Position) -mkGrid text = (forest, slides, start, end) +mkGrid text = ((S.union forest caps), slides, start, end) where rows = lines text maxR = length rows - 1 maxC = (length $ head rows) - 1 forest = S.fromList [ V2 r c | r <- [0..maxR], c <- [0..maxC] , rows !! r !! c == '#' ] - slides = M.fromList [ (V2 r c, readSlide (rows !! r !! c)) + slides = M.fromList [ (V2 r c, readSlide (rows !! r !! c)) | r <- [0..maxR], c <- [0..maxC] , elem (rows !! r !! c) ("<>^v" :: String) ] @@ -81,6 +130,7 @@ mkGrid text = (forest, slides, start, end) end = head $ [ V2 maxR c | c <- [0..maxC] , rows !! maxR !! c == '.' ] + caps = S.fromList [start ^+^ (V2 -1 0), end ^+^ (V2 1 0)] readSlide :: Char -> Slide readSlide '<' = SlideLeft -- 2.34.1