Solve 2023-04

src/AoC.hs

@@ -28,5 +28,9 @@ handleError :: IOError.IOError -> IO ()
 handleError e = do
   hPutStrLn stderr $ "I ran into an issue: " <> show e
 
+printResult :: Either Text Solution -> IO ()
+printResult (Left e) = putTextLn e
+printResult (Right s) = print s
+
 defaultMain :: IO ()
-defaultMain = Exception.catch (runAoC Y2023 D03 >>= print) handleError
+defaultMain = Exception.catch (runAoC Y2023 D04 >>= printResult) handleError

src/AoC/Riddle.hs

@@ -3,6 +3,9 @@ module AoC.Riddle (
   Error,
   Solution,
   loadRiddle,
+  loadExample,
+  module AoC.Day,
+  module AoC.Year,
 ) where
 
 import AoC.Util (readFileUtf8)
@@ -15,6 +18,12 @@ type Error = Text
 type Solution = [Integer]
 
 loadRiddle :: (MonadIO m) => Year -> Day -> m Riddle
-loadRiddle y d = readFileUtf8 inputFile
+loadRiddle = loadFile "riddle"
+
+loadExample :: (MonadIO m) => Year -> Day -> m Riddle
+loadExample = loadFile "example"
+
+loadFile :: (MonadIO m) => FilePath -> Year -> Day -> m Riddle
+loadFile f y d = readFileUtf8 inputFile
  where
-  inputFile = intercalate "/" ["data", show y, show d, "riddle"]
+  inputFile = intercalate "/" ["data", show y, show d, f]

src/AoC/Y2023/D03.hs

@@ -1,10 +1,8 @@
-module AoC.Y2023.D03 where
+module AoC.Y2023.D03 (solve) where
 
 import AoC.Riddle
 import Data.Array
 import Data.Char (isDigit)
-import Relude (catMaybes, fromIntegral, readMaybe)
-import System.Posix.Internals (const_fd_cloexec)
 
 type Pos = (Int, Int)
 type Item = (Pos, Char)
@@ -76,18 +74,34 @@ expand arr f pos = ls <> rs
         then i : go (move p dt) dt
         else []
 
-toPartNumber :: [Item] -> Maybe Integer
-toPartNumber = readMaybe . fmap snd
+toPartNumber :: [Item] -> Maybe (Pos, Integer)
+toPartNumber [] = Nothing
+toPartNumber (x@(p, _) : xs) = do
+  n <- readMaybe . fmap snd $ x : xs
+  pure (p, n)
 
 part1 :: Puzzle -> Integer
 part1 puzzle = sum partNumbers
  where
-  partNumbers = mapMaybe toPartNumber (ordNub (concatMap (fmap (expand puzzle isDigit . fst) . neighbors puzzle . fst) syms))
+  partNumbers = snd <$> mapMaybe toPartNumber (ordNub (concatMap (fmap (expand puzzle isDigit . fst) . neighbors puzzle . fst) syms))
   syms = symbols puzzle
 
+part2 :: Puzzle -> Integer
+part2 puzzle = sum ratios
+ where
+  ratios = fmap product $ snd <<$>> gears
+  gears = filter ((== 2) <$> length) $ fmap (ordNub . catMaybes) $ toPartNumber <<$>> fmap (expand puzzle isDigit . fst) . neighbors puzzle . fst <$> gs
+  gs = gearCandidates puzzle
+
+gearCandidates :: Puzzle -> [Item]
+gearCandidates = filter ((== '*') <$> snd) . symbols
+
 solve :: (MonadIO m) => Text -> m (Either Text Solution)
 solve input = do
   let
     puzzle = parse input
-    p1 = part1 puzzle
-  pure $ Right [part1 puzzle]
+  pure $
+    Right
+      [ part1 puzzle
+      , part2 puzzle
+      ]

src/AoC/Y2023/D04.hs

@@ -1,6 +1,86 @@
-module AoC.Y2023.D04 (solve) where
+{-# LANGUAGE RecordWildCards #-}
+{-# OPTIONS_GHC -Wno-type-defaults #-}
+
+module AoC.Y2023.D04 where
 
 import AoC.Riddle
+import Data.IntMap qualified as IntMap
+import Data.List (intersect)
+import Data.Text (splitOn)
+
+type Cards = [Int]
+
+data Game = Game
+  { winningCards :: Cards
+  , playedCards :: Cards
+  }
+  deriving stock (Show)
+
+type Puzzle = [Game]
+
+-- | parse the whole puzzle
+--
+-- >>> length . parse <$> loadExample Y2023 D04
+-- 6
+parse :: Riddle -> Puzzle
+parse = fmap parseGame . lines
+
+parseGame :: Text -> Game
+parseGame input =
+  case splitOn ": " input of
+    [_, game] -> case splitOn " | " game of
+      [w, h] -> Game{winningCards = parseCards w, playedCards = parseCards h}
+      _ -> Game mempty mempty
+    _ -> Game mempty mempty
+
+parseCards :: Text -> Cards
+parseCards = mapMaybe (readMaybe . toString) . splitOn " "
+
+-- | calculate winning cards
+--
+-- >>> winningNumbers $ Game [41,48,83,86,17] [83,86,6,31,17,9,48,53]
+-- [48,83,86,17]
+winningNumbers :: Game -> Cards
+winningNumbers Game{..} = winningCards `intersect` playedCards
+
+-- | calculate the score of the given card
+--
+-- >>> score [48,83,86,17]
+-- 8
+score :: Cards -> Integer
+score [] = 0
+score card = (2 :: Integer) ^ (genericLength card - 1)
+
+-- | calculate the first part
+--
+-- >>> part1 . parse <$> loadExample Y2023 D04
+-- 13
+part1 :: Puzzle -> Integer
+part1 = sum . fmap (score . winningNumbers)
+
+-- | calculate the second part
+--
+-- >>> fmap (length . winningNumbers) . parse <$> loadExample Y2023 D04
+-- [4,2,2,1,0,0]
+--
+-- >>> part2 . parse <$> loadExample Y2023 D04
+-- 30
+part2 :: Puzzle -> Integer
+part2 game = fromIntegral . sum . foldl' step initial . zip [1 ..] . fmap (length . winningNumbers) $ game
+ where
+  initial = IntMap.fromList . map (,1) $ [1 .. length game]
+  step :: IntMap Int -> (Int, Int) -> IntMap Int
+  step m c = IntMap.unionWith (+) m (copies m c)
+
+  copies :: IntMap Int -> (Int, Int) -> IntMap Int
+  copies _ (_, 0) = IntMap.empty
+  copies m (c, w) =
+    let
+      totalCopies = fromMaybe 0 . IntMap.lookup c $ m
+     in
+      IntMap.fromList $ map (,totalCopies) $ take w [c + 1 ..]
 
 solve :: (MonadIO m) => Text -> m (Either Text Solution)
-solve _ = pure $ Left "not yet implemented"
+solve riddle = do
+  let puzzle = parse riddle
+  pure $ Right [part1 puzzle, part2 puzzle]