|
| 1 | +{-| |
| 2 | +Module: Day22 |
| 3 | +Description: <https://adventofcode.com/2022/day/22 Day 22: Monkey Map> |
| 4 | +-} |
| 5 | +{-# LANGUAGE LambdaCase, MultiWayIf, NondecreasingIndentation, OverloadedStrings, ParallelListComp, RecordWildCards, ScopedTypeVariables, TransformListComp, TypeFamilies, ViewPatterns #-} |
| 6 | +module Day22 (day22a, day22b) where |
| 7 | + |
| 8 | +import Control.Arrow (first) |
| 9 | +import Data.Either (partitionEithers) |
| 10 | +import Data.Function (on) |
| 11 | +import Data.Ix (inRange) |
| 12 | +import Data.List (find, foldl', foldl1', groupBy) |
| 13 | +import Data.List.Split (chunksOf) |
| 14 | +import Data.Map (Map) |
| 15 | +import qualified Data.Map as Map ((!?), fromList) |
| 16 | +import Data.Maybe (fromJust, maybeToList) |
| 17 | +import Data.Text (Text) |
| 18 | +import qualified Data.Text as T (findIndex, index, length, lines, null, uncons) |
| 19 | +import qualified Data.Text.Read as T (decimal) |
| 20 | +import Data.Vector (Vector) |
| 21 | +import qualified Data.Vector as V ((!), (!?), fromList, head, length) |
| 22 | + |
| 23 | +data Move a = Move a | TurnL | TurnR |
| 24 | +data Dir = R | D | L | U deriving (Enum, Eq, Ord) |
| 25 | + |
| 26 | +readsPath :: (Integral a) => Text -> ([Move a], Text) |
| 27 | +readsPath (T.decimal -> Right (n, s)) = let ~(path, s') = readsPath s in (Move n:path, s') |
| 28 | +readsPath (T.uncons -> Just ('L', s)) = let ~(path, s') = readsPath s in (TurnL:path, s') |
| 29 | +readsPath (T.uncons -> Just ('R', s)) = let ~(path, s') = readsPath s in (TurnR:path, s') |
| 30 | +readsPath s = ([], s) |
| 31 | + |
| 32 | +turnRight, turn180, turnLeft :: Dir -> Dir |
| 33 | +turnRight d = toEnum $ (fromEnum d + 1) `mod` 4 |
| 34 | +turn180 d = toEnum $ (fromEnum d + 2) `mod` 4 |
| 35 | +turnLeft d = toEnum $ (fromEnum d + 3) `mod` 4 |
| 36 | + |
| 37 | +step :: (Num a) => Dir -> (a, a) -> (a, a) |
| 38 | +step R (x, y) = (x + 1, y) |
| 39 | +step D (x, y) = (x, y + 1) |
| 40 | +step L (x, y) = (x - 1, y) |
| 41 | +step U (x, y) = (x, y - 1) |
| 42 | + |
| 43 | +get :: Vector Text -> (Int, Int) -> Char |
| 44 | +get maze (x, y) |
| 45 | + | Just line <- maze V.!? y, inRange (0, T.length line - 1) x = T.index line x |
| 46 | + | otherwise = ' ' |
| 47 | + |
| 48 | +mazePerimeter :: Vector Text -> [((Int, Int), Dir)] |
| 49 | +mazePerimeter maze |
| 50 | + | Just x0 <- maze V.!? 0 >>= T.findIndex (== '.') |
| 51 | + = let initial:rest = iterate step' ((x0, 0), R) in initial:takeWhile (/= initial) rest where |
| 52 | + step' (p, d) |
| 53 | + | ' ' <- get maze p' = (p, turnRight d) |
| 54 | + | ' ' <- get maze p'' = (p', d) |
| 55 | + | otherwise = (p'', turnLeft d) |
| 56 | + where |
| 57 | + p' = step d p |
| 58 | + p'' = step (turnLeft d) p' |
| 59 | +mazePerimeter _ = [] |
| 60 | + |
| 61 | +mazeEdges2D, mazeEdges3D :: Vector Text -> Map ((Int, Int), Dir) ((Int, Int), Dir) |
| 62 | +mazeEdges2D maze = Map.fromList |
| 63 | + [ ((p, d'), (wrap d' p, d')) |
| 64 | + | x0 <- maybeToList $ maze V.!? 0 >>= T.findIndex (== '.') |
| 65 | + , (p, d) <- mazePerimeter maze |
| 66 | + , let d' = turnLeft d |
| 67 | + ] where |
| 68 | + wrap d (x, y) = fromJust . find ((/= ' ') . get maze) $ case d of |
| 69 | + R -> [(x', y) | x' <- [0..x]] |
| 70 | + D -> [(x, y') | y' <- [0..y]] |
| 71 | + L -> [(x', y) | let line = maze V.! y, x' <- [T.length line - 1, T.length line - 2..x]] |
| 72 | + U -> [(x, y') | y' <- [V.length maze - 1, V.length maze - 2..y]] |
| 73 | +mazeEdges3D maze = Map.fromList $ concat |
| 74 | + [ [((p, turnLeft d), (q, turnRight e)), ((q, turnLeft e), (p, turnRight d))] |
| 75 | + | (edge1, edge2) <- joinedEdges |
| 76 | + , ((p, d), (q, e)) <- zip edge1 $ reverse edge2 |
| 77 | + ] where |
| 78 | + perimeter = mazePerimeter maze |
| 79 | + sideLength = foldl1' gcd . map length $ groupBy ((==) `on` snd) perimeter |
| 80 | + joinEdges [] = [] |
| 81 | + joinEdges edges |
| 82 | + | [] <- joined = error "loop" |
| 83 | + | otherwise = joined ++ joinEdges remaining where |
| 84 | + (joined, remaining) = partitionEithers $ joinEdges' edges |
| 85 | + joinEdges' ((d1, e1):(d2, e2):edges) |
| 86 | + | turnLeft d1 == d2 = Left (e1, e2) : joinEdges' (first turnLeft <$> edges) |
| 87 | + joinEdges' (edge:edges) = Right edge : joinEdges' edges |
| 88 | + joinEdges' [] = [] |
| 89 | + joinedEdges = joinEdges [(dir, edge) | edge@((_, dir):_) <- chunksOf sideLength perimeter] |
| 90 | + |
| 91 | +day22 :: (Vector Text -> Map ((Int, Int), Dir) ((Int, Int), Dir)) -> Text -> Int |
| 92 | +day22 mazeEdges input = 1000 * (y + 1) + 4 * (x + 1) + fromEnum d where |
| 93 | + (V.fromList -> maze, [_, readsPath -> (path, "")]) = break T.null $ T.lines input |
| 94 | + Just x0 = T.findIndex (== '.') $ V.head maze |
| 95 | + edges = mazeEdges maze |
| 96 | + step' s | Just s' <- edges Map.!? s = s' |
| 97 | + step' (p, d) = (step d p, d) |
| 98 | + go s (Move n) = last . takeWhile ((== '.') . get maze . fst) . take (n + 1) $ iterate step' s |
| 99 | + go (p, d) TurnL = (p, turnLeft d) |
| 100 | + go (p, d) TurnR = (p, turnRight d) |
| 101 | + ((x, y), d) = foldl' go ((x0, 0), R) path |
| 102 | + |
| 103 | +day22a :: Text -> Int |
| 104 | +day22a = day22 mazeEdges2D |
| 105 | + |
| 106 | +day22b :: Text -> Int |
| 107 | +day22b = day22 mazeEdges3D |
0 commit comments