advent23/Main.hs

   1 -- Writeup at https://work.njae.me.uk/2023/12/29/advent-of-code-2023-day-21/
   2
   3 import AoC
   4 import Linear (V2(..), (^+^))
   5 import qualified Data.Set as S
   6 import qualified Data.Map as M
   7
   8 data Slide = SlideLeft | SlideRight | SlideUp | SlideDown
   9   deriving (Show, Eq)
  10
  11 type Position = V2 Int -- r, c
  12 type Grid = S.Set Position
  13 type Slides = M.Map Position Slide
  14
  15 main :: IO ()
  16 main =
  17   do  dataFileName <- getDataFileName
  18       text <- readFile dataFileName
  19       let (forest, slides, start, end) = mkGrid text
  20       -- print forest
  21       -- print slides
  22       -- print start
  23       -- print end
  24       -- print $ searchStep slides forest [start ^+^ (V2 1 0), start]
  25       -- let paths = search slides forest end [] [[start ^+^ (V2 1 0), start]]
  26       -- print $ fmap length paths
  27       print $ part1 slides forest start end
  28
  29 part1 slides forest start end = (maximum $ fmap length paths) - 1
  30   where paths = search slides forest end [] [[start ^+^ (V2 1 0), start]]
  31
  32 adjacents :: Position -> Slides -> Grid -> [Position]
  33 adjacents here slides walls = filter (`S.notMember` walls) $ fmap (^+^ here) deltas
  34   where deltas = case M.lookup here slides of
  35                   Nothing ->  [ V2 0 1, V2 1 0, V2 0 (-1), V2 (-1) 0 ]
  36                   Just SlideLeft -> [ V2 0 (-1) ]
  37                   Just SlideRight -> [ V2 0 1 ]
  38                   Just SlideUp -> [ V2 (-1) 0 ]
  39                   Just SlideDown -> [ V2 1 0 ]
  40
  41 searchStep :: Slides -> Grid -> [Position] -> [[Position]]
  42 searchStep _ _ [] = []
  43 searchStep slides forest path@(here:rest) = fmap (:path) valids
  44   where nexts = adjacents here slides forest
  45         valids = filter (`notElem` rest) nexts
  46
  47
  48 search :: Slides -> Grid -> Position -> [[Position]] -> [[Position]] -> [[Position]]
  49 search _ _ _ foundPaths [] = foundPaths
  50 search slides forest goal foundPaths (current:agenda)
  51   | head current == goal = search slides forest goal (current:foundPaths) agenda
  52   | otherwise = search slides forest goal foundPaths (agenda ++ extendeds)
  53   where extendeds = searchStep slides forest current
  54
  55
  56 -- showGrid :: Grid -> (Position, Position) -> Grid -> String
  57 -- showGrid rocks bounds cells = unlines $ intercalate [" "] $ chunksOf 7 $ fmap (showRow rocks bounds cells) [-28..34]
  58 --   where showRow rocks bounds cells r = intercalate " " $ chunksOf 7 $ fmap ((showCell rocks bounds cells) . V2 r) [-28..34]
  59 --         showCell rocks bounds cells here
  60 --           | not $ notAtRock rocks bounds here = '#'
  61 --           | here `S.member` cells = 'O'
  62 --           | otherwise = '.'
  63
  64 -- reading the map
  65
  66 mkGrid :: String -> (Grid, Slides, Position, Position)
  67 mkGrid text = (forest, slides, start, end)
  68   where rows = lines text
  69         maxR = length rows - 1
  70         maxC = (length $ head rows) - 1
  71         forest = S.fromList [ V2 r c | r <- [0..maxR], c <- [0..maxC]
  72                             , rows !! r !! c == '#'
  73                             ]
  74         slides = M.fromList [ (V2 r c, readSlide (rows !! r !! c))
  75                             | r <- [0..maxR], c <- [0..maxC]
  76                             , elem (rows !! r !! c) ("<>^v" :: String)
  77                             ]
  78         start = head $ [ V2 0 c | c <- [0..maxC]
  79                        , rows !! 0 !! c == '.'
  80                        ]
  81         end = head $ [ V2 maxR c | c <- [0..maxC]
  82                      , rows !! maxR !! c == '.'
  83                      ]
  84
  85 readSlide :: Char -> Slide
  86 readSlide '<' = SlideLeft
  87 readSlide '>' = SlideRight
  88 readSlide '^' = SlideUp
  89 readSlide 'v' = SlideDown