Day 22: Monkey Map

README.md

@@ -27,3 +27,4 @@ Development occurs in language-specific directories:
 |[Day19.hs](hs/src/Day19.hs)|[Day19.kt](kt/src/commonMain/kotlin/com/github/ephemient/aoc2022/Day19.kt)|[day19.py](py/aoc2022/day19.py)|[day19.rs](rs/src/day19.rs)|
 |[Day20.hs](hs/src/Day20.hs)|[Day20.kt](kt/src/commonMain/kotlin/com/github/ephemient/aoc2022/Day20.kt)|[day20.py](py/aoc2022/day20.py)|[day20.rs](rs/src/day20.rs)|
 |[Day21.hs](hs/src/Day21.hs)|[Day21.kt](kt/src/commonMain/kotlin/com/github/ephemient/aoc2022/Day21.kt)|[day21.py](py/aoc2022/day21.py)|[day21.rs](rs/src/day21.rs)|
+|[Day22.hs](hs/src/Day22.hs)|

hs/aoc2022.cabal

@@ -32,6 +32,7 @@ data-files:
   , day19.txt
   , day20.txt
   , day21.txt
+  , day22.txt
 
 extra-source-files:
     README.md
@@ -60,6 +61,7 @@ library
       , Day19
       , Day20
       , Day21
+      , Day22
     build-depends:
         array ^>=0.5.4.0
       , base ^>=4.16.0.0
@@ -123,6 +125,7 @@ test-suite aoc2022-test
       , Day19Spec
       , Day20Spec
       , Day21Spec
+      , Day22Spec
     hs-source-dirs:   test
     default-language: GHC2021
     build-tool-depends:

hs/app/Main.hs

@@ -23,6 +23,7 @@ import Day18 (day18a, day18b)
 import Day19 (day19a, day19b)
 import Day20 (day20a, day20b)
 import Day21 (day21a, day21b)
+import Day22 (day22a, day22b)
 
 import Control.Monad ((<=<), ap, when)
 import Data.Function (on)
@@ -73,3 +74,4 @@ main = do
     run 19 (either (fail . errorBundlePretty) print) [day19a, day19b]
     run 20 (either fail print) [day20a, day20b]
     run 21 (either (fail . errorBundlePretty) print) [day21a, day21b]
+    run 22 print [day22a, day22b]

hs/bench/Main.hs

@@ -26,6 +26,7 @@ import Day18 (day18a, day18b)
 import Day19 (day19a, day19b)
 import Day20 (day20a, day20b)
 import Day21 (day21a, day21b)
+import Day22 (day22a, day22b)
 import Paths_aoc2022 (getDataFileName)
 import System.Environment.Blank (getEnv, setEnv, unsetEnv)
 
@@ -126,4 +127,8 @@ main = defaultMain
       [ bench "part 1" $ nf day21a input
       , bench "part 2" $ nf day21b input
       ]
+  , env (getDayInput 22) $ \input -> bgroup "Day 22"
+      [ bench "part 1" $ nf day22a input
+      , bench "part 2" $ nf day22b input
+      ]
   ]

hs/src/Day22.hs

@@ -0,0 +1,107 @@
+{-|
+Module:         Day22
+Description:    <https://adventofcode.com/2022/day/22 Day 22: Monkey Map>
+-}
+{-# LANGUAGE LambdaCase, MultiWayIf, NondecreasingIndentation, OverloadedStrings, ParallelListComp, RecordWildCards, ScopedTypeVariables, TransformListComp, TypeFamilies, ViewPatterns #-}
+module Day22 (day22a, day22b) where
+
+import Control.Arrow (first)
+import Data.Either (partitionEithers)
+import Data.Function (on)
+import Data.Ix (inRange)
+import Data.List (find, foldl', foldl1', groupBy)
+import Data.List.Split (chunksOf)
+import Data.Map (Map)
+import qualified Data.Map as Map ((!?), fromList)
+import Data.Maybe (fromJust, maybeToList)
+import Data.Text (Text)
+import qualified Data.Text as T (findIndex, index, length, lines, null, uncons)
+import qualified Data.Text.Read as T (decimal)
+import Data.Vector (Vector)
+import qualified Data.Vector as V ((!), (!?), fromList, head, length)
+
+data Move a = Move a | TurnL | TurnR
+data Dir = R | D | L | U deriving (Enum, Eq, Ord)
+
+readsPath :: (Integral a) => Text -> ([Move a], Text)
+readsPath (T.decimal -> Right (n, s)) = let ~(path, s') = readsPath s in (Move n:path, s')
+readsPath (T.uncons -> Just ('L', s)) = let ~(path, s') = readsPath s in (TurnL:path, s')
+readsPath (T.uncons -> Just ('R', s)) = let ~(path, s') = readsPath s in (TurnR:path, s')
+readsPath s = ([], s)
+
+turnRight, turn180, turnLeft :: Dir -> Dir
+turnRight d = toEnum $ (fromEnum d + 1) `mod` 4
+turn180 d = toEnum $ (fromEnum d + 2) `mod` 4
+turnLeft d = toEnum $ (fromEnum d + 3) `mod` 4
+
+step :: (Num a) => Dir -> (a, a) -> (a, a)
+step R (x, y) = (x + 1, y)
+step D (x, y) = (x, y + 1)
+step L (x, y) = (x - 1, y)
+step U (x, y) = (x, y - 1)
+
+get :: Vector Text -> (Int, Int) -> Char
+get maze (x, y)
+  | Just line <- maze V.!? y, inRange (0, T.length line - 1) x = T.index line x
+  | otherwise = ' '
+
+mazePerimeter :: Vector Text -> [((Int, Int), Dir)]
+mazePerimeter maze
+  | Just x0 <- maze V.!? 0 >>= T.findIndex (== '.')
+  = let initial:rest = iterate step' ((x0, 0), R) in initial:takeWhile (/= initial) rest where
+    step' (p, d)
+      | ' ' <- get maze p' = (p, turnRight d)
+      | ' ' <- get maze p'' = (p', d)
+      | otherwise = (p'', turnLeft d)
+      where
+        p' = step d p
+        p'' = step (turnLeft d) p'
+mazePerimeter _ = []
+
+mazeEdges2D, mazeEdges3D :: Vector Text -> Map ((Int, Int), Dir) ((Int, Int), Dir)
+mazeEdges2D maze = Map.fromList
+  [ ((p, d'), (wrap d' p, d'))
+  | x0 <- maybeToList $ maze V.!? 0 >>= T.findIndex (== '.')
+  , (p, d) <- mazePerimeter maze
+  , let d' = turnLeft d
+  ] where
+    wrap d (x, y) = fromJust . find ((/= ' ') . get maze) $ case d of
+        R -> [(x', y) | x' <- [0..x]]
+        D -> [(x, y') | y' <- [0..y]]
+        L -> [(x', y) | let line = maze V.! y, x' <- [T.length line - 1, T.length line - 2..x]]
+        U -> [(x, y') | y' <- [V.length maze - 1, V.length maze - 2..y]]
+mazeEdges3D maze = Map.fromList $ concat
+  [ [((p, turnLeft d), (q, turnRight e)), ((q, turnLeft e), (p, turnRight d))]
+  | (edge1, edge2) <- joinedEdges
+  , ((p, d), (q, e)) <- zip edge1 $ reverse edge2
+  ] where
+    perimeter = mazePerimeter maze
+    sideLength = foldl1' gcd . map length $ groupBy ((==) `on` snd) perimeter
+    joinEdges [] = []
+    joinEdges edges
+      | [] <- joined = error "loop"
+      | otherwise = joined ++ joinEdges remaining where
+        (joined, remaining) = partitionEithers $ joinEdges' edges
+    joinEdges' ((d1, e1):(d2, e2):edges)
+      | turnLeft d1 == d2 = Left (e1, e2) : joinEdges' (first turnLeft <$> edges)
+    joinEdges' (edge:edges) = Right edge : joinEdges' edges
+    joinEdges' [] = []
+    joinedEdges = joinEdges [(dir, edge) | edge@((_, dir):_) <- chunksOf sideLength perimeter]
+
+day22 :: (Vector Text -> Map ((Int, Int), Dir) ((Int, Int), Dir)) -> Text -> Int
+day22 mazeEdges input = 1000 * (y + 1) + 4 * (x + 1) + fromEnum d where
+    (V.fromList -> maze, [_, readsPath -> (path, "")]) = break T.null $ T.lines input
+    Just x0 = T.findIndex (== '.') $ V.head maze
+    edges = mazeEdges maze
+    step' s | Just s' <- edges Map.!? s = s'
+    step' (p, d) = (step d p, d)
+    go s (Move n) = last . takeWhile ((== '.') . get maze . fst) . take (n + 1) $ iterate step' s
+    go (p, d) TurnL = (p, turnLeft d)
+    go (p, d) TurnR = (p, turnRight d)
+    ((x, y), d) = foldl' go ((x0, 0), R) path
+
+day22a :: Text -> Int
+day22a = day22 mazeEdges2D
+
+day22b :: Text -> Int
+day22b = day22 mazeEdges3D

hs/test/Day22Spec.hs

@@ -0,0 +1,34 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Day22Spec (spec) where
+
+import Data.Text (Text)
+import qualified Data.Text as T (unlines)
+import Day22 (day22a, day22b)
+import Test.Hspec (Spec, describe, it, shouldBe)
+
+example :: Text
+example = T.unlines
+  [ "        ...#"
+  , "        .#.."
+  , "        #..."
+  , "        ...."
+  , "...#.......#"
+  , "........#..."
+  , "..#....#...."
+  , "..........#."
+  , "        ...#...."
+  , "        .....#.."
+  , "        .#......"
+  , "        ......#."
+  , ""
+  , "10R5L5R10L4R5L5"
+  ]
+
+spec :: Spec
+spec = do
+    describe "part 1" $ do
+        it "examples" $ do
+            day22a example `shouldBe` 6032
+    describe "part 2" $ do
+        it "examples" $ do
+            day22b example `shouldBe` 5031