advent10/Main.hs

   1 -- Writeup at https://work.njae.me.uk/2023/12/10/advent-of-code-2023-day-10/
   2
   3 import AoC
   4
   5 import Data.List hiding (map)
   6 import Data.List.Split
   7 import Prelude hiding (map)
   8 import Data.Maybe
   9 import Linear (V2(..), (^+^))
  10 import Linear.Vector ((^*))
  11 import Data.Array.IArray
  12 import qualified Data.Set as S
  13
  14 data Pipe = Empty |
  15             NorthWest | NorthSouth | NorthEast |
  16             WestEast | WestSouth |
  17             SouthEast |
  18             Start
  19             deriving (Show, Eq, Enum)
  20
  21 type Position = V2 Int -- r, c
  22 type Grid = Array Position Pipe
  23
  24 data Map = Map { getGrid :: Grid, getStart :: Position } deriving (Show)
  25
  26 type Path = [Position]
  27
  28 type BGrid = Array Position Bool
  29 type Region = S.Set Position
  30
  31 main :: IO ()
  32 main =
  33   do  dataFileName <- getDataFileName
  34       text <- readFile dataFileName
  35       let map = mkMap text
  36       let loop = fromJust $ search map
  37       print $ part1 loop
  38       print $ part2 map loop
  39
  40 part1 :: Path -> Int
  41 part1 loop = (length loop) `div` 2
  42
  43 part2 :: Map -> Path -> Int
  44 part2 map loop = S.size $ truePoints $ head iRegions
  45   where bgrid = expand (getGrid map) loop
  46         regions = regionsFromMap map loop
  47         iRegions = innerRegions bgrid $ filter (not . S.null) regions
  48
  49 -- reading the map
  50
  51 mkMap :: String -> Map
  52 mkMap text = Map grid' start
  53   where grid = mkGrid text
  54         start = head $ filter (( == Start) . (grid !)) $ indices grid
  55         grid' = grid // [(start, startIs $ Map grid start)]
  56
  57 mkGrid :: String -> Grid
  58 mkGrid text = grid
  59   where rows = lines text
  60         r = length rows - 1
  61         c = (length $ head rows) - 1
  62         grid = listArray ((V2 0 0), (V2 r c)) $ fmap readPipe $ concat rows
  63
  64 readPipe :: Char -> Pipe
  65 readPipe 'J' = NorthWest
  66 readPipe '|' = NorthSouth
  67 readPipe 'L' = NorthEast
  68 readPipe '-' = WestEast
  69 readPipe '7' = WestSouth
  70 readPipe 'F' = SouthEast
  71 readPipe 'S' = Start
  72 readPipe _ = Empty
  73
  74 deltas :: Pipe -> [Position]
  75 deltas NorthWest = [V2 (-1) 0, V2 0 (-1)]
  76 deltas NorthSouth = [V2 (-1) 0, V2 1 0]
  77 deltas NorthEast = [V2 (-1) 0, V2 0 1]
  78 deltas WestEast = [V2 0 (-1), V2 0 1]
  79 deltas WestSouth = [V2 0 (-1), V2 1 0]
  80 deltas SouthEast = [V2 1 0, V2 0 1]
  81 deltas Start = (deltas NorthSouth) ++ (deltas WestEast)
  82 deltas Empty = []
  83
  84 neighbours :: Map -> Position -> [Position]
  85 neighbours Map{..} p = filter (inRange $ bounds getGrid) $
  86                               fmap (^+^ p) $ deltas $ getGrid ! p
  87
  88 connectorsToStart :: Map -> [Position]
  89 connectorsToStart map@Map{..} = fmap fst connectors
  90   where nbrs = neighbours map getStart
  91         nbrsNbrs = fmap (\n -> (n, neighbours map n)) nbrs
  92         connectors = filter ((getStart `elem`) . snd) nbrsNbrs
  93
  94 startIs :: Map -> Pipe
  95 startIs map = head [ t | t <- [NorthWest .. SouthEast]
  96                        , (sort $ fmap (^+^ s) $ deltas t) == conns ]
  97   where conns = sort $ connectorsToStart map
  98         s = getStart map
  99
 100 -- Part 1: finding the loop
 101
 102 search :: Map -> Maybe Path
 103 search map = dfs map (initial map)
 104
 105 dfs :: Map -> [Path] -> Maybe Path
 106 dfs _ [] = Nothing
 107 dfs map (p:ps)
 108   | isGoal map p = Just p
 109   | otherwise = dfs map $ (successors map p) ++ ps
 110
 111 successors :: Map -> Path -> [Path]
 112 successors map p = fmap (:p) ns'
 113   where ns = neighbours map $ head p
 114         ns' = filter (`notElem` p) ns
 115
 116 isGoal :: Map -> Path -> Bool
 117 isGoal map p@(h:_) = ((getStart map) `elem` (neighbours map h)) && length p >= 3
 118
 119 initial :: Map -> [Path]
 120 initial map = fmap (:[s]) $ neighbours map s
 121   where s = getStart map
 122
 123 -- finding the inner region
 124
 125 expand :: Grid -> Path -> BGrid
 126 expand grid path = foldl' (addWall grid) bgrid path
 127   where (b0, b1) = bounds grid
 128         b' = (b0, (b1 ^* 2) ^+^ (V2 1 1))
 129         bgrid = array b' [(p, False) | p <- range b']
 130
 131 addWall :: Grid -> BGrid -> Position -> BGrid
 132 addWall grid bgrid p = bgrid // fmap ((, True)) adds
 133   where wallCell = grid ! p
 134         ds = deltas wallCell
 135         p' = p ^* 2
 136         adds = p' : fmap (^+^ p') ds
 137
 138 showBGrid :: BGrid -> String
 139 showBGrid bgrid = unlines $ fmap (fmap showCell) rows
 140   where rows = chunksOf (c + 1) $ elems bgrid
 141         (_, V2 _ c) = bounds bgrid
 142         showCell True = '#'
 143         showCell False = '.'
 144
 145 fill :: [Position] -> Region -> BGrid -> Region
 146 fill [] region _ = region
 147 fill (p:ps) region bgrid
 148   | bgrid ! p = fill ps region bgrid
 149   | p `S.member` region = fill ps region bgrid
 150   | otherwise = fill (ps ++ ns) region' bgrid
 151   where ns = bNeighbours bgrid p
 152         region' = S.insert p region
 153
 154 bNeighbours :: BGrid -> Position -> [Position]
 155 bNeighbours g p = filter (inRange $ bounds g) $ unboundedNeighbours p
 156
 157 unboundedNeighbours :: Position -> [Position]
 158 unboundedNeighbours p = fmap (^+^ p) [V2 (-1) 0, V2 1 0, V2 0 (-1), V2 0 1]
 159
 160 getRegions :: BGrid -> [Position] -> [Region]
 161 getRegions bgrid starts = fmap (\s -> fill [s] S.empty bgrid) starts
 162
 163 regionsFromMap :: Map -> Path -> [Region]
 164 regionsFromMap map boundary = getRegions bgrid starts
 165   where bgrid = expand (getGrid map) boundary
 166         starts = filter (inRange $ bounds bgrid) $
 167                         fmap (\n -> n ^+^ (getStart map ^* 2))
 168                               [V2 dr dc | dr <- [-1, 0, 1], dc <- [-1, 0, 1]]
 169
 170 onEdge :: BGrid -> Position -> Bool
 171 onEdge bgrid p = any (not . inRange (bounds bgrid)) $ unboundedNeighbours p
 172
 173 touchesEdge :: BGrid -> Region -> Bool
 174 touchesEdge bgrid region = any (onEdge bgrid) $ S.toList region
 175
 176 innerRegions :: BGrid -> [Region] -> [Region]
 177 innerRegions bgrid regions = filter (not . touchesEdge bgrid) regions
 178
 179 truePoints :: Region -> Region
 180 truePoints = S.filter (\(V2 r c) -> r `mod` 2 == 0 && c `mod` 2 == 0)