Done day 20 part 1
[advent-of-code-23.git] / 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)