Solve 2024-05

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)]