2023 day 7 in Haskell

$ time cabal run < input >/dev/null
cabal run < input > /dev/null  0.22s user 0.02s system 96% cpu 0.241 total

2023/07/Day07.cabal

@@ -0,0 +1,19 @@
+cabal-version:   3.0
+name:            Day07
+version:         0.1.0.0
+license:         NONE
+build-type:      Simple
+extra-doc-files: CHANGELOG.md
+
+common warnings
+    ghc-options: -Wall
+
+executable Day07
+    import:           warnings
+    main-is:          Day07.hs
+    build-depends:    base ^>=4.17.2.1
+                    , attoparsec ^>=0.14.4
+                    , text ^>=2.1
+                    , containers ^>=0.6.7
+    hs-source-dirs:   .
+    default-language: Haskell2010

2023/07/Day07.hs

@@ -0,0 +1,100 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main where
+
+import Data.Attoparsec.Text
+import Data.List (group, sort, sortOn)
+import qualified Data.Text as T
+import qualified Data.Text.IO as TIO
+
+type Input = [(Hand, [Int], Int)]
+
+data Hand
+  = HighCard
+  | OnePair
+  | TwoPairs
+  | ThreeOfAKind
+  | FullHouse
+  | FourOfAKind
+  | FiveOfAKind
+  deriving (Show, Eq, Ord)
+
+main :: IO ()
+main = do
+  input <- TIO.getContents >>= parseInput
+  putStrLn ("Part 1: " <> show (part1 input))
+  putStrLn ("Part 2: " <> show (part2 input))
+
+parseInput :: T.Text -> IO Input
+parseInput s = case parseOnly inputParser s of
+  Right i -> pure i
+  Left e -> error e
+
+inputParser :: Parser Input
+inputParser = sepBy1 lineParser endOfLine <* skipSpace <* endOfInput
+
+lineParser :: Parser (Hand, [Int], Int)
+lineParser = do
+  cards <- (map cardValue . T.unpack <$> takeWhile1 (inClass "2-9TJQKA")) <* skipSpace
+  bid <- decimal
+  return (classifyHand cards, cards, bid)
+
+part1 :: Input -> Int
+part1 i = sum $ [rank * bid | ((_, _, bid), rank) <- rankHands i]
+
+values :: [(Int, Char)]
+values = zip [2 ..] $ ['2' .. '9'] ++ ['T', 'J', 'Q', 'K', 'A']
+
+part2 :: Input -> Int
+part2 i = part1 $ map part2Revalue i
+
+part2Revalue :: (Hand, [Int], Int) -> (Hand, [Int], Int)
+part2Revalue (_, cards, bid) = (pickBestJokers revaluedCards, revaluedCards, bid)
+  where
+    revaluedCards = map revalueCard cards
+
+revalueCard :: Int -> Int
+revalueCard x
+  | x == 11 = 1
+  | x > 11 = x - 1
+  | otherwise = x
+
+cardValue :: Char -> Int
+cardValue c = fst $ head $ filter (\v -> snd v == c) values
+
+classifyHand :: [Int] -> Hand
+classifyHand h = case groups of
+  [5] -> FiveOfAKind
+  [1, 4] -> FourOfAKind
+  [2, 3] -> FullHouse
+  [1, 1, 3] -> ThreeOfAKind
+  [1, 2, 2] -> TwoPairs
+  [1, 1, 1, 2] -> OnePair
+  [1, 1, 1, 1, 1] -> HighCard
+  _ -> error "There should be 5 cards in a hand"
+  where
+    groups = counts h
+
+rankHands :: [(Hand, [Int], Int)] -> [((Hand, [Int], Int), Int)]
+rankHands h = zip (sortOn (\(a, b, _) -> (a, b)) h) [1 ..]
+
+counts :: [Int] -> [Int]
+counts = sort . map length . group . sort
+
+pickBestJokers :: [Int] -> Hand
+pickBestJokers = maximum . map classifyHand . expandJokers
+
+expandJoker :: Int -> [Int]
+expandJoker 1 = [2 .. 13]
+expandJoker x = [x]
+
+expandJokers :: [Int] -> [[Int]]
+expandJokers [a, b, c, d, e] =
+  [ [a1, b1, c1, d1, e1]
+    | a1 <- expandJoker a,
+      b1 <- expandJoker b,
+      c1 <- expandJoker c,
+      d1 <- expandJoker d,
+      e1 <- expandJoker e
+  ]
+expandJokers _ = error "Expected a list with five elements"

2023/07/example

@@ -0,0 +1,5 @@
+32T3K 765
+T55J5 684
+KK677 28
+KTJJT 220
+QQQJA 483