WIP: 2024-06

data/Y2024/D05/example

@@ -0,0 +1,28 @@
+47|53
+97|13
+97|61
+97|47
+75|29
+61|13
+75|53
+29|13
+97|29
+53|29
+61|53
+97|53
+61|29
+47|13
+75|47
+97|75
+47|61
+75|61
+47|29
+75|13
+53|13
+
+75,47,61,53,29
+97,61,53,29,13
+75,29,13
+75,97,47,61,53
+61,13,29
+97,13,75,29,47

data/Y2024/D06/example

@@ -0,0 +1,10 @@
+....#.....
+.........#
+..........
+..#.......
+.......#..
+..........
+.#..^.....
+........#.
+#.........
+......#...

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/D05.hs

@@ -1,6 +1,88 @@
+{- HLINT ignore "Use bimapF" -}
+{-# LANGUAGE RecordWildCards #-}
+
 module AoC.Y2024.D05 (solve) where
 
 import AoC.Riddle
 
+-- import Data.Set qualified as S
+
+import Data.Set qualified as S
+import Data.String (lines)
+import Data.Text (splitOn)
+import Prelude hiding (lines)
+
+data Puzzle = Puzzle
+  { orderingRules :: Rules
+  , updates :: [Update]
+  }
+  deriving stock (Show)
+
+type Rules = Set (Page, Page)
+type Page = Int
+type Update = [Page]
+
+parse :: Riddle -> Maybe Puzzle
+parse riddle = do
+  let
+    (p1, p2) = break null $ lines $ toString riddle
+  p2' <- nonEmpty p2
+  Puzzle <$> parseOrderings p1 <*> parseRules (tail p2')
+
+parseOrderings :: [String] -> Maybe Rules
+parseOrderings s = do
+  p <- traverse (\l -> (,) <$> readMaybe (take 2 l) <*> readMaybe (drop 3 l)) s
+  pure $ fromList p
+
+parseRules :: [String] -> Maybe [Update]
+parseRules = mapM parseRule
+
+parseRule :: String -> Maybe Update
+parseRule = mapM readMaybe . fmap toString . splitOn "," . toText
+
+isSafe :: Rules -> Update -> Bool
+isSafe _ [] = True
+isSafe rules (u : us) = correctlyPositioned rules u us && isSafe rules us
+
+correctlyPositioned :: Rules -> Page -> Update -> Bool
+correctlyPositioned rules page = all (correctlyPositionedAgainst rules page)
+
+correctlyPositionedAgainst :: Rules -> Page -> Page -> Bool
+correctlyPositionedAgainst rules a b = S.member (a, b) rules && S.notMember (b, a) rules
+
+middlePage :: [a] -> Maybe a
+middlePage update = case length update `mod` 2 of
+  0 -> Nothing
+  _ ->
+    let
+      half = length update `div` 2
+      m = drop half $ take (half + 1) update
+     in
+      case m of
+        [p] -> Just p
+        _ -> Nothing
+
+sortCorrectly :: Puzzle -> Puzzle
+sortCorrectly Puzzle{..} = Puzzle{orderingRules, updates = fixedUpdates}
+ where
+  fixedUpdates :: [Update]
+  fixedUpdates = sortBy f <$> filter (not . isSafe orderingRules) updates
+
+  f :: Page -> Page -> Ordering
+  f a b = case (S.member (a, b) orderingRules, S.member (b, a) orderingRules) of
+    (True, _) -> LT
+    (_, True) -> GT
+    _ -> EQ
+
+part1 :: Riddle -> Maybe Int
+part1 riddle = do
+  Puzzle{..} <- parse riddle
+  sum <$> mapM middlePage (filter (isSafe orderingRules) updates)
+
+part2 :: Riddle -> Maybe Int
+part2 riddle = do
+  Puzzle{..} <- sortCorrectly <$> parse riddle
+  sum <$> mapM middlePage (filter (isSafe orderingRules) updates)
+
 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)]

src/AoC/Y2024/D06.hs

@@ -1,6 +1,101 @@
+{-# LANGUAGE LambdaCase #-}
+{- HLINT ignore "Use bimapF" -}
+{-# LANGUAGE RecordWildCards #-}
+
 module AoC.Y2024.D06 (solve) where
 
 import AoC.Riddle
+import AoC.Util
+
+import Data.Array qualified as A
+
+-- import Data.Set qualified as S
+
+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)
+    } ->
+    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'
+
+locateGuard :: Matrix Tile -> Maybe (Position, Direction)
+locateGuard = lookupGuard . fmap swap . A.assocs
+ where
+  lookupGuard :: [(Tile, Position)] -> Maybe (Position, Direction)
+  lookupGuard = getFirst . foldMap checkGuard
+
+  checkGuard :: (Tile, Position) -> First (Position, Direction)
+  checkGuard (Guard d, pos) = pure (pos, d)
+  checkGuard _ = mempty
+
+parse :: Riddle -> Maybe MapState
+parse riddle = do
+  labMap <- parseMap riddle
+  pure $ MapState{labMap, guardPosition = locateGuard labMap}
+
+movePosition :: Position -> Direction -> Position
+movePosition (x, y) d =
+  let (dx, dy) = directionToVector d
+   in (x + dx, y + dy)
+
+moveGuard :: MapState -> Maybe (Position, MapState)
+moveGuard MapState{..} = do
+  (pos, d) <- guardPosition
+  case d of {}
+
+part1 :: Riddle -> Maybe Int
+part1 riddle = Nothing
+
+part2 :: Riddle -> Maybe Int
+part2 riddle = Nothing
 
 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)]

test/spec/AoCSpec/Y2024Spec.hs

@@ -21,8 +21,6 @@ spec = do
     it "calculates correctly" do
       runAoC Y2024 D04 `shouldReturn` Right [2567, 2029]
 
-{-
   describe "Day 5" do
-    it "calculates the example correctly" do
+    it "calculates correctly" do
-      runAoCExample Y2023 D05 `shouldReturn` Right [35]
+      runAoC Y2024 D05 `shouldReturn` Right [5452, 4598]
--}