Solve 2023-02

src/AoC/Y2023/D02.hs

@@ -1,6 +1,89 @@
-module AoC.Y2023.D02 (solve) where
+module AoC.Y2023.D02 where
 
 import AoC.Riddle
 
+import Data.Map (foldMapWithKey)
+import Data.Map qualified as M
+import Text.Megaparsec (Parsec, choice, parse, sepBy, sepEndBy1)
+import Text.Megaparsec.Char (char, eol, space1, string)
+import Text.Megaparsec.Char.Lexer qualified as L
+
+type Parser = Parsec Void Text
+
+data Cube = Red | Green | Blue
+  deriving stock (Eq, Ord, Enum, Show)
+
+parseText :: Parser a -> Text -> Either Text a
+parseText p t = case parse p "<inline>" t of
+  Right a -> pure a
+  Left e -> Left $ show e
+
+-- skip whitespace
+ws :: Parser ()
+ws = L.space space1 empty empty
+
+linewise :: Parser a -> Parser [a]
+linewise p = p `sepEndBy1` eol
+
+type Round = Map Cube Integer
+
+pRound :: Parser Round
+pRound = fromList <$> pCubes `sepBy` (char ',' >> ws)
+
+pCube :: Parser Cube
+pCube =
+  choice
+    [ Red <$ string "red"
+    , Green <$ string "green"
+    , Blue <$ string "blue"
+    ]
+
+pCubes :: Parser (Cube, Integer)
+pCubes = do
+  n <- L.decimal
+  _ <- space1
+  c <- pCube
+  pure (c, n)
+
+type Game = (Integer, [Round])
+
+pGame :: Parser Game
+pGame = do
+  _ <- string "Game" >> ws
+  n <- L.decimal
+  _ <- char ':' >> ws
+  rs <- pRound `sepBy` (char ';' >> ws)
+  pure (n, rs)
+
+pPuzzle :: Parser [Game]
+pPuzzle = linewise pGame
+
+isGameValid :: Game -> Bool
+isGameValid (_, rounds) = all isRoundValid rounds
+
+isRoundValid :: Round -> Bool
+isRoundValid = getAll . foldMapWithKey (\c n -> All $ cubesPossible c n)
+
+cubesPossible :: Cube -> Integer -> Bool
+cubesPossible Red = (<= 12)
+cubesPossible Green = (<= 13)
+cubesPossible Blue = (<= 14)
+
+minimumSet :: Game -> Round
+minimumSet (_, rounds) = foldr (M.unionWith max) M.empty rounds
+
+power :: Round -> Integer
+power = product . M.elems
+
 solve :: (MonadIO m) => Text -> m (Either Text Solution)
-solve _ = pure $ Left "not yet implemented"
+solve riddle = case parseText pPuzzle riddle of
+  Right puzzle ->
+    let
+      part1 :: Integer
+      part1 = sum . fmap fst . filter isGameValid $ puzzle
+
+      part2 :: Integer
+      part2 = sum . fmap (power . minimumSet) $ puzzle
+     in
+      pure $ Right [part1, part2]
+  Left e -> pure $ Left e