Solve 2024-04

src/AoC/Y2024/D04.hs

@@ -1,6 +1,97 @@
-module AoC.Y2024.D04 (solve) where
+{- HLINT ignore "Use bimapF" -}
+
+module AoC.Y2024.D04 (solve, example) where
 
 import AoC.Riddle
 
+import Data.Array
+
+type Index = (Int, Int)
+type Puzzle = Array Index Char
+
+-- | example data
+example :: Text
+example =
+  unlines
+    [ "MMMSXXMASM"
+    , "MSAMXMSMSA"
+    , "AMXSXMAAMM"
+    , "MSAMASMSMX"
+    , "XMASAMXAMM"
+    , "XXAMMXXAMA"
+    , "SMSMSASXSS"
+    , "SAXAMASAAA"
+    , "MAMMMXMMMM"
+    , "MXMXAXMASX"
+    ]
+
+mkArray :: [[a]] -> Array Index a
+mkArray vss =
+  array
+    ((1, 1), (w, h))
+    [ ((x, y), v)
+    | (y, vs) <- zip [1 ..] vss
+    , (x, v) <- zip [1 ..] vs
+    ]
+ where
+  w = case vss of
+    [] -> 0
+    (vs : _) -> length vs
+  h = length vss
+
+neighbors :: Int -> (Index, Index) -> Index -> [[Index]]
+neighbors n b i = filter (\is -> length is == 4) (take n <$> result)
+ where
+  directions = [(dx, dy) | dx <- [-1, 0, 1], dy <- [-1, 0, 1], (dx, dy) /= (0, 0)]
+  move :: Index -> [Index]
+  move (dx, dy) = i : Prelude.unfoldr (\(x, y) -> let p = (x + dx, y + dy) in if inRange b p then Just (p, p) else Nothing) i
+  result = move <$> directions
+
+extractPath :: Puzzle -> [Index] -> String
+extractPath p path = (p !) <$> path
+
+extractPaths :: Puzzle -> [[Index]] -> [String]
+extractPaths p paths = extractPath p <$> paths
+
+extract :: String -> Puzzle -> [String]
+extract w p = Prelude.filter (== w) $ extractPaths p (Prelude.concatMap (neighbors (Prelude.length w) (bounds p)) (indices p))
+
+xmasStencil :: [[Index]]
+xmasStencil =
+  [ [(-1, -1), (0, 0), (1, 1)]
+  , [(1, -1), (0, 0), (-1, 1)]
+  ]
+
+line :: (Index, Index) -> Index -> [Index] -> Maybe [Index]
+line b (x, y) xs = result
+ where
+  candidate = filter (inRange b) . fmap (bimap (x +) (y +)) $ xs
+  result = if length candidate == length xs then Just candidate else Nothing
+
+getXs :: Puzzle -> [[String]]
+getXs p = result
+ where
+  stencil :: Index -> [[Index]]
+  stencil i = mapMaybe (line (bounds p) i) xmasStencil
+
+  result = filter (\xs -> length xs == 2) $ extractPaths p . stencil <$> indices p
+
+extractX :: String -> Puzzle -> [[String]]
+extractX s = filter (all (\w -> w == s || w == reverse s)) . getXs
+
+parse :: Riddle -> Puzzle
+parse riddle = result
+ where
+  input :: [[Char]]
+  input = toString <$> lines riddle
+
+  result = mkArray input
+
+part1 :: Riddle -> Int
+part1 = length . extract "XMAS" . parse
+
+part2 :: Riddle -> Int
+part2 = length . extractX "MAS" . parse
+
 solve :: (MonadIO m) => Text -> m (Either Text Solution)
-solve _ = pure $ Left "not yet implemented"
+solve riddle = pure $ Right [fromIntegral $ part1 riddle, fromIntegral $ part2 riddle]