Done day 24
[advent-of-code-22.git] / advent22 / Main.hs
1 -- Writeup at https://work.njae.me.uk/2022/12/19/advent-of-code-2022-day-18/
2
3 -- import Debug.Trace
4
5 import AoC
6 import Prelude hiding (Left, Right)
7 import qualified Data.Map.Strict as M
8 import Data.Map.Strict ((!))
9 import Linear hiding (E)
10 import Control.Lens
11 import Data.Ix
12 import Data.Maybe
13 import Data.Char
14 import Control.Monad.Reader
15
16
17 type Position = V2 Int -- r, c
18 _r :: Lens' (V2 Int) Int
19 _r = _x
20 _c :: Lens' (V2 Int) Int
21 _c = _y
22
23 data Cell = Tile | Wall
24 deriving (Show, Eq)
25
26 type FieldMap = M.Map Position Cell
27
28 data Direction = Right | Down | Left | Up
29 deriving (Show, Eq, Ord, Enum, Bounded)
30
31 predW, succW :: (Eq a, Bounded a, Enum a) => a -> a
32 predW a
33 | a == minBound = maxBound
34 | otherwise = pred a
35 succW a
36 | a == maxBound = minBound
37 | otherwise = succ a
38
39 data PathElement = Forward Int | Clockwise | Anticlockwise
40 deriving (Show, Eq)
41
42 data Person = Person {_position :: Position, _facing :: Direction}
43 deriving (Show, Eq)
44 makeLenses ''Person
45
46 data Field = Field { getMap :: FieldMap
47 , whatsAheadFunc :: Person -> FieldContext Person
48 -- , whatsAtFunc :: Position -> FieldContext Cell
49 }
50 type FieldContext = Reader Field
51
52 data Face = A | B | C | D | E | F
53 deriving (Show, Eq)
54
55 main :: IO ()
56 main =
57 do dataFileName <- getDataFileName
58 text <- readFile dataFileName
59 let (field, instrs) = successfulParse text
60 print $ part1 field instrs
61 print $ part2 field instrs
62 -- print $ probeAllCorners field
63
64 part1, part2 :: FieldMap -> [PathElement] -> Int
65 part1 fieldMap instrs = passwordOf endPerson
66 where field = mkFlatField fieldMap
67 startPos = V2 0 $ fromJust $ minimumOf (folded . filteredBy (_r . only 0) . _c) $ M.keysSet fieldMap
68 startPerson = Person startPos Right
69 endPerson = runReader (walk startPerson instrs) field
70
71 part2 fieldMap instrs = passwordOf endPerson
72 where field = mkCubeField fieldMap
73 startPos = V2 0 $ fromJust $ minimumOf (folded . filteredBy (_r . only 0) . _c) $ M.keysSet fieldMap
74 startPerson = Person startPos Right
75 endPerson = runReader (walk startPerson instrs) field
76
77 -- probeCube fieldMap startPos startDirection = endPerson
78 -- where field = mkCubeField fieldMap
79 -- startPerson = Person startPos startDirection
80 -- endPerson = runReader (whatsAheadCube startPerson) field
81
82 -- probeAllCorners fieldMap = [(p, probeACorner p field) | p <- persons]
83 -- where persons = [ Person (V2 r c) f
84 -- | r <- [0, 49, 50, 99, 100, 149]
85 -- , c <- [0, 49, 50, 99, 100, 149, 150, 199]
86 -- , f <- [Right, Down, Left, Up]
87 -- , (V2 r c) `M.member` fieldMap
88 -- ]
89 -- field = mkCubeField fieldMap
90
91 -- probeACorner person field
92 -- | Debug.Trace.trace (show person) False = undefined
93 -- | otherwise = runReader (whatsAheadCube person) field
94
95
96 passwordOf :: Person -> Int
97 passwordOf person = 1000 * (person ^. position . _r + 1)
98 + 4 * (person ^. position . _c + 1)
99 + (fromEnum $ person ^. facing)
100
101
102 mkFlatField :: FieldMap -> Field
103 mkFlatField fieldMap =
104 Field { getMap = fieldMap
105 , whatsAheadFunc = whatsAheadFlat
106 -- , whatsAtFunc = whatsAt
107 }
108
109
110 mkCubeField :: FieldMap -> Field
111 mkCubeField fieldMap =
112 Field { getMap = fieldMap
113 , whatsAheadFunc = whatsAheadCube
114 -- , whatsAtFunc = whatsAt
115 }
116
117 whatsAt :: Position -> FieldContext Cell
118 whatsAt posiiton =
119 do fieldMap <- asks getMap
120 return $ fieldMap ! posiiton
121
122 whatsAheadFlat :: Person -> FieldContext Person
123 whatsAheadFlat person =
124 do let easyNext = (person ^. position) + (deltaOf $ person ^. facing)
125 fieldMap <- asks getMap
126 if easyNext `M.member` fieldMap
127 then return $ person & position .~ easyNext
128 else do let currenFacing = person ^. facing
129 let currentRow = person ^. position . _r
130 let currentCol = person ^. position . _c
131 let rightMovingCol = fromJust $ minimumOf (folded . filteredBy (_r . only currentRow) . _c) $ M.keysSet fieldMap
132 let leftMovingCol = fromJust $ maximumOf (folded . filteredBy (_r . only currentRow) . _c) $ M.keysSet fieldMap
133 let upMovingRow = fromJust $ maximumOf (folded . filteredBy (_c . only currentCol) . _r) $ M.keysSet fieldMap
134 let downMovingRow = fromJust $ minimumOf (folded . filteredBy (_c . only currentCol) . _r) $ M.keysSet fieldMap
135 return $ case currenFacing of
136 Right -> person & position . _c .~ rightMovingCol
137 Left -> person & position . _c .~ leftMovingCol
138 Up -> person & position . _r .~ upMovingRow
139 Down -> person & position . _r .~ downMovingRow
140
141
142 -- A B
143 -- C
144 -- D E
145 -- F
146
147 whatsAheadCube :: Person -> FieldContext Person
148 whatsAheadCube person =
149 do let easyNext = (person ^. position) + (deltaOf $ person ^. facing)
150 let currentFace = faceOf (person ^. position)
151 let nextFace = faceOf easyNext
152 fieldMap <- asks getMap
153 if (easyNext `M.member` fieldMap) && (currentFace == nextFace)
154 then return $ person & position .~ easyNext
155 else return $ crossEdge person currentFace
156
157 faceOf :: Position -> Face
158 faceOf position
159 | (inRange (0, 49) r) && (inRange (50, 99) c) = A
160 | (inRange (0, 49) r) && (inRange (100, 149) c) = B
161 | (inRange (50, 99) r) && (inRange (50, 99) c) = C
162 | (inRange (100, 149) r) && (inRange (0, 49) c) = D
163 | (inRange (100, 149) r) && (inRange (50, 99) c) = E
164 | (inRange (150, 199) r) && (inRange (0, 49) c) = F
165 | otherwise = error "Not a face"
166 where r = position ^. _r
167 c = position ^. _c
168
169 crossEdge :: Person -> Face -> Person
170 crossEdge person face =
171 case (d, face) of
172 (Up, A) -> person & position . _r .~ (interpol c 150 199) & position . _c .~ 0 & facing .~ Right
173 (Right, A) -> person & position . _c .~ 100
174 (Down, A) -> person & position . _r .~ 50
175 (Left, A) -> person & position . _r .~ (interpol r 149 100) & position . _c .~ 0 & facing .~ Right
176
177 (Up, B) -> person & position . _r .~ 199 & position . _c .~ (interpol c 0 49)
178 (Right, B) -> person & position . _r .~ (interpol r 149 100) & position . _c .~ 99 & facing .~ Left
179 (Down, B) -> person & position . _r .~ (interpol c 50 99) & position . _c .~ 99 & facing .~ Left
180 (Left, B) -> person & position . _c .~ 99
181
182 (Up, C) -> person & position . _r .~ 49
183 (Right, C) -> person & position . _r .~ 49 & position . _c .~ (interpol r 100 149) & facing .~ Up
184 (Down, C) -> person & position . _r .~ 100
185 (Left, C) -> person & position . _r .~ 100 & position . _c .~ (interpol r 0 49) & facing .~ Down
186
187 (Up, D) -> person & position . _r .~ (interpol c 50 99) & position . _c .~ 50 & facing .~ Right
188 (Right, D) -> person & position . _c .~ 50
189 (Down, D) -> person & position . _r .~ 150
190 (Left, D) -> person & position . _r .~ (interpol r 49 0) & position . _c .~ 50 & facing .~ Right
191
192 (Up, E) -> person & position . _r .~ 99
193 (Right, E) -> person & position . _r .~ (interpol r 49 0) & position . _c .~ 149 & facing .~ Left
194 (Down, E) -> person & position . _r .~ (interpol c 150 199) & position . _c .~ 49 & facing .~ Left
195 (Left, E) -> person & position . _c .~ 49
196
197 (Up, F) -> person & position . _r .~ 149
198 (Right, F) -> person & position . _r .~ 149 & position . _c .~ (interpol r 50 99) & facing .~ Up
199 (Down, F) -> person & position . _r .~ 0 & position . _c .~ (interpol c 100 149)
200 (Left, F) -> person & position . _r .~ 0 & position . _c .~ (interpol r 50 99) & facing .~ Down
201
202 where r = person ^. position . _r
203 c = person ^. position . _c
204 d = person ^. facing
205 interpol x start end = (signum (end - start)) * (x `mod` 50) + start
206
207
208 walk :: Person -> [PathElement] -> FieldContext Person
209 walk person path = foldM walkOne person path
210
211 walkOne :: Person -> PathElement -> FieldContext Person
212 walkOne person (Forward n)
213 | n == 0 = return person
214 | otherwise =
215 do whatsAhead <- asks whatsAheadFunc
216 person' <- whatsAhead person
217 -- whatsAt <- asks whatsAtFunc
218 nextCell <- whatsAt (person' ^. position)
219 if nextCell == Wall
220 then return person
221 else walkOne person' (Forward (n - 1))
222 walkOne person Clockwise = return $ person & facing %~ succW
223 walkOne person Anticlockwise = return $ person & facing %~ predW
224
225 deltaOf :: Direction -> Position
226 deltaOf Right = V2 0 1
227 deltaOf Down = V2 1 0
228 deltaOf Left = V2 0 -1
229 deltaOf Up = V2 -1 0
230
231
232 -- Parse the input file
233
234 successfulParse :: String -> (FieldMap, [PathElement])
235 successfulParse text = (mkField $ takeWhile ((> 0) . length) $ init $ lines text, mkInstructions $ last $ lines text)
236
237 mkField :: [String] -> FieldMap
238 mkField rows = M.fromList
239 [ (V2 r c, mkCell r c)
240 | r <- [0..maxR], c <- [0..maxC]
241 , isCell r c rows
242 ]
243 where maxR = length rows - 1
244 maxC = (length $ head rows) - 1
245 -- isCell r c = ((rows !! r) !! c) `elem` (".#" :: String)
246 mkCell r c
247 | cell == '.' = Tile
248 | cell == '#' = Wall
249 where cell = (rows !! r) !! c
250
251 isCell :: Int -> Int -> [String] -> Bool
252 isCell r c rows = isRow && isCol && ((rows !! r) !! c) `elem` (".#" :: String)
253 where isRow = r < length rows
254 isCol = c < (length $ rows !! r)
255
256 mkInstructions :: String -> [PathElement]
257 mkInstructions [] = []
258 mkInstructions text@(t:ts)
259 | isDigit t = mkWalk text
260 | otherwise = mkTurn text
261 mkWalk text = (Forward $ read digits) : (mkInstructions remainder)
262 where (digits, remainder) = span (isDigit) text
263 mkTurn (t:ts)
264 | t == 'R' = Clockwise : (mkInstructions ts)
265 | t == 'L' = Anticlockwise : (mkInstructions ts)