WIP: Solve 2024-06

src/AoC/Util.hs

@@ -1,5 +1,8 @@
 -- | Internal module in order to facilitate testability.
-module AoC.Util (solveRiddle, readFileUtf8) where
+module AoC.Util (solveRiddle, readFileUtf8, module A, mkMatrix, Matrix) where
+
+import Data.Array (Array)
+import Data.Array qualified as A
 
 readFileUtf8 :: (MonadIO m) => FilePath -> m Text
 readFileUtf8 = fmap (decodeUtf8With lenientDecode) . readFileBS
@@ -9,3 +12,19 @@ solveRiddle file solver = do
   results <- solver <$> readFileUtf8 file
   forM_ (results `zip` [1 :: Int ..]) $ \(solution, part) ->
     putTextLn $ "  solution to part-" <> show part <> ": " <> solution
+
+type Matrix a = Array (Int, Int) a
+
+mkMatrix :: [[a]] -> Matrix a
+mkMatrix vss =
+  A.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

src/AoC/Y2024/D06.hs

@@ -1,6 +1,179 @@
+{- HLINT ignore "Use bimapF" -}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE RecordWildCards #-}
+
 module AoC.Y2024.D06 (solve) where
 
 import AoC.Riddle
+import AoC.Util
+
+import Data.Array ((!), (//))
+import Data.Array qualified as A
+
+import Data.String (lines)
+import Prelude hiding (lines)
+
+data Direction
+  = U
+  | R
+  | D
+  | L
+  deriving stock (Show, Eq, Enum)
+
+data Tile
+  = Free
+  | Obstruction
+  | Visited
+  | Guard Direction
+  deriving stock (Show, Eq)
+
+type Position = (Int, Int)
+
+directionToVector :: Direction -> Position
+directionToVector = \case
+  U -> (0, -1)
+  R -> (1, 0)
+  D -> (0, 1)
+  L -> (-1, 0)
+
+parseTile :: Char -> Maybe Tile
+parseTile = \case
+  '.' -> pure Free
+  '#' -> pure Obstruction
+  '^' -> pure $ Guard U
+  '>' -> pure $ Guard R
+  'v' -> pure $ Guard D
+  '<' -> pure $ Guard L
+  _ -> Nothing
+
+data MapState where
+  MapState ::
+    { labMap :: Matrix Tile
+    , guardPosition :: Maybe (Position, Direction)
+    , candidatesForLoop :: [Position]
+    } ->
+    MapState
+  deriving stock (Show)
+
+parseMap :: Riddle -> Maybe (Matrix Tile)
+parseMap riddle = do
+  let
+    vss :: [[Char]]
+    vss = lines . toString $ riddle
+
+    vss' :: [Maybe [Tile]]
+    vss' = mapM parseTile <$> vss
+
+  mkMatrix <$> sequence vss'
+
+newMapState :: Matrix Tile -> MapState
+newMapState labMap =
+  MapState labMap (locateGuard labMap) []
+
+locateGuard :: Matrix Tile -> Maybe (Position, Direction)
+locateGuard = getFirst . foldMap checkGuard . A.assocs
+ where
+  checkGuard :: (Position, Tile) -> First (Position, Direction)
+  checkGuard (pos, Guard d) = pure (pos, d)
+  checkGuard _ = mempty
+
+parse :: Riddle -> Maybe MapState
+parse riddle = newMapState <$> parseMap riddle
+
+movePosition :: Position -> Direction -> Position
+movePosition (x, y) d =
+  let (dx, dy) = directionToVector d
+   in (x + dx, y + dy)
+
+getTile :: Matrix Tile -> Position -> Maybe Tile
+getTile m pos =
+  guard (A.inRange (A.bounds m) pos) >> Just (m ! pos)
+
+turnRight :: Direction -> Direction
+turnRight = \case
+  U -> R
+  R -> D
+  D -> L
+  L -> U
+
+moveGuard :: MapState -> MapState
+moveGuard s@MapState{..} = case guardPosition of
+  Nothing -> s
+  Just (pos, d) ->
+    let
+      newPos = movePosition pos d
+     in
+      case getTile labMap newPos of
+        Just Obstruction -> do
+          let
+            newDirection = turnRight d
+          s
+            { labMap = labMap // [(pos, Guard newDirection)]
+            , guardPosition = Just (pos, newDirection)
+            }
+        Just Visited ->
+          let
+            s' =
+              s
+                { labMap = labMap // [(pos, Visited), (newPos, Guard d)]
+                , guardPosition = Just (newPos, d)
+                }
+            newPos' = movePosition newPos d
+           in
+            case getTile labMap newPos' of
+              Nothing -> s'
+              Just Obstruction -> s'
+              Just _ -> s'{candidatesForLoop = newPos' : s'.candidatesForLoop}
+        Just _ ->
+          s
+            { labMap = labMap // [(pos, Visited), (newPos, Guard d)]
+            , guardPosition = Just (newPos, d)
+            }
+        Nothing ->
+          s
+            { labMap = labMap // [(pos, Visited)]
+            , guardPosition = Nothing
+            }
+
+updateGuard :: Maybe (Position, Direction) -> MapState -> MapState
+updateGuard Nothing s =
+  case s.guardPosition of
+    Nothing -> s
+    Just (pos, _) ->
+      s
+        { labMap = s.labMap // [(pos, Visited)]
+        , guardPosition = Nothing
+        }
+updateGuard g@(Just (pos, dir)) s =
+  case s.guardPosition of
+    Nothing ->
+      s
+        { labMap = s.labMap // [(pos, Guard dir)]
+        , guardPosition = g
+        }
+    Just (pos', _) ->
+      s
+        { labMap = s.labMap // [(pos', Visited), (pos, Guard dir)]
+        , guardPosition = g
+        }
+
+guardLeftTheMap :: MapState -> Bool
+guardLeftTheMap MapState{..} = isNothing guardPosition
+
+moveGuardUntilSheLeaves :: MapState -> Maybe MapState
+moveGuardUntilSheLeaves =
+  viaNonEmpty head . dropWhile (not . guardLeftTheMap) . iterate moveGuard
+
+part1 :: Riddle -> Maybe Int
+part1 riddle = do
+  MapState{..} <- parse riddle >>= moveGuardUntilSheLeaves
+  pure $ length $ filter (\(_, t) -> t == Visited) (A.assocs labMap)
+
+part2 :: Riddle -> Maybe Int
+part2 riddle = do
+  MapState{..} <- parse riddle >>= moveGuardUntilSheLeaves
+  pure $ length candidatesForLoop
 
 solve :: (MonadIO m) => Text -> m (Either Text Solution)
-solve _ = pure $ Left "not yet implemented"
+solve riddle = pure $ Right [fromIntegral $ fromMaybe 0 (part1 riddle), fromIntegral $ fromMaybe 0 (part2 riddle)]