[haskell] Day 7

haskell/aoc2023.cabal

@@ -26,6 +26,7 @@ library
                     , Day4
                     , Day5
                     , Day6
+                    , Day7
 
 executable aoc2023
     import:           warnings

haskell/app/Main.hs

@@ -8,6 +8,7 @@ import Day3 qualified
 import Day4 qualified
 import Day5 qualified
 import Day6 qualified
+import Day7 qualified
 import System.Environment (getArgs)
 
 main :: IO ()
@@ -19,4 +20,5 @@ main = do
     ["day4"] -> Day4.run
     ["day5"] -> Day5.run
     ["day6"] -> Day6.run
+    ["day7"] -> Day7.run
     args -> error $ "Invlaid args: " <> show args

haskell/src/Day7.hs

@@ -0,0 +1,259 @@
+{-# LANGUAGE LambdaCase #-}
+
+module Day7 where
+
+import Control.Monad (replicateM)
+import Data.Char (isDigit)
+import Data.Functor ((<&>))
+import Data.List (sort, sortBy)
+import Data.Map.Lazy qualified as Map
+import Data.Ord (comparing)
+import Text.ParserCombinators.ReadP
+import Data.Function (on)
+
+run :: IO ()
+run = do
+  input <- readInput
+  putStrLn $ "Part 1 Answer: " <> show (part1 input)
+  putStrLn $ "Part 2 Answer: " <> show (part2 input)
+
+part1 :: [(Hand, Bid)] -> Int
+part1 handsWithBids =
+  let sortedHandsWithBids = sort handsWithBids
+   in sum $ zipWith (\(_, bid) rank -> bid * rank) sortedHandsWithBids [1 ..]
+
+part2 :: [(Hand, Bid)] -> Int
+part2 handsWithBids =
+  let sortedHandsWithBids = sortBy (jokerCompare `on` fst) handsWithBids
+   in sum $ zipWith (\(_, bid) rank -> bid * rank) sortedHandsWithBids [1 ..]
+
+-- | Order of the constructors is important
+--
+-- >>> HighCard `compare` FiveOfAKind
+-- LT
+--
+-- >>> FullHouse `compare` ThreeOfAKind
+-- GT
+data HandType
+  = HighCard
+  | OnePair
+  | TwoPair
+  | ThreeOfAKind
+  | FullHouse
+  | FourOfAKind
+  | FiveOfAKind
+  deriving (Eq, Ord, Show)
+
+-- |
+-- >>> handType $ Hand [K,K,K,K,K]
+-- FiveOfAKind
+--
+-- >>> handType $ Hand [C2,C2,C2,C2,K]
+-- FourOfAKind
+--
+-- >>> handType $ Hand [K,J,K,C2,J]
+-- TwoPair
+--
+-- >>> handType $ Hand [K,A,J,Q,A]
+-- OnePair
+--
+-- >>> handType $ Hand [A,J,A,C2,A]
+-- ThreeOfAKind
+--
+-- >>> handType $ Hand [A,A,A,K,K]
+-- FullHouse
+handType :: [Card] -> HandType
+handType cards =
+  let counts = foldr (\c -> Map.insertWith (+) c (1 :: Int)) mempty cards
+   in case maximum counts of
+        1 -> HighCard
+        2
+          | length (Map.filter (== 2) counts) == 2 -> TwoPair
+          | otherwise -> OnePair
+        3
+          | 2 `elem` counts -> FullHouse
+          | otherwise -> ThreeOfAKind
+        4 -> FourOfAKind
+        5 -> FiveOfAKind
+        _ -> error "Too many cards"
+
+-- |
+-- >>> jokerHandType [J,J,J,J,J]
+-- FiveOfAKind
+--
+-- >>> jokerHandType [Q,Q,Q,Q,Q]
+-- FiveOfAKind
+--
+-- >>> jokerHandType [Q,Q,Q,Q,J]
+-- FiveOfAKind
+--
+-- >>> jokerHandType [Q,Q,Q,J,J]
+-- FiveOfAKind
+--
+-- >>> jokerHandType [Q,Q,Q,K,J]
+-- FourOfAKind
+--
+-- >>> jokerHandType [Q,Q,A,K,J]
+-- ThreeOfAKind
+--
+-- >>> jokerHandType [Q,Q,A,A,J]
+-- FullHouse
+--
+-- >>> jokerHandType [Q,Q,Q,A,A]
+-- FullHouse
+--
+-- >>> jokerHandType [Q,Q,A,K,K]
+-- TwoPair
+--
+-- >>> jokerHandType [T,J,Q,K,A]
+-- OnePair
+--
+-- >>> jokerHandType [T,J,J,K,A]
+-- ThreeOfAKind
+jokerHandType :: [Card] -> HandType
+jokerHandType cards =
+  let jokers = length $ filter (== J) cards
+      withoutJokers = filter (/= J) cards
+   in case length withoutJokers of
+        0 -> FiveOfAKind
+        5 -> handType withoutJokers
+        _ ->
+          let countsWithoutJoker = foldr (\c -> Map.insertWith (+) c (1 :: Int)) mempty withoutJokers
+              pairsCount = Map.size (Map.filter (== 2) countsWithoutJoker)
+           in case maximum countsWithoutJoker of
+                5 -> FiveOfAKind
+                4
+                  | jokers == 1 -> FiveOfAKind
+                  | otherwise -> FourOfAKind
+                3
+                  | jokers == 2 -> FiveOfAKind
+                  | otherwise -> FourOfAKind
+                2
+                  | jokers == 3 -> FiveOfAKind
+                  | jokers == 2 -> FourOfAKind
+                  | jokers == 1 && pairsCount == 2 -> FullHouse
+                  | otherwise -> ThreeOfAKind
+                1
+                  | jokers == 4 -> FiveOfAKind
+                  | jokers == 3 -> FourOfAKind
+                  | jokers == 2 -> ThreeOfAKind
+                  | otherwise -> OnePair
+                _ -> error "too many cards"
+
+-- Order of the constructors is important
+data Card
+  = C2
+  | C3
+  | C4
+  | C5
+  | C6
+  | C7
+  | C8
+  | C9
+  | T
+  | J
+  | Q
+  | K
+  | A
+  deriving (Eq, Ord, Show)
+
+instance JokerOrd Card where
+  jokerCompare :: Card -> Card -> Ordering
+  jokerCompare J J = EQ
+  jokerCompare J _ = LT
+  jokerCompare _ J = GT
+  jokerCompare c1 c2 = c1 `compare` c2
+
+newtype Hand = Hand [Card]
+  deriving (Eq)
+
+instance Show Hand where
+  show :: Hand -> String
+  show (Hand cardOrder) =
+    foldMap
+      ( \c ->
+          case show c of
+            ['C', x] -> [x]
+            xs -> xs
+      )
+      cardOrder
+
+class JokerOrd a where
+  jokerCompare :: a -> a -> Ordering
+
+instance (JokerOrd a) => JokerOrd [a] where
+  jokerCompare [] [] = EQ
+  jokerCompare [] _ = LT
+  jokerCompare _ [] = GT
+  jokerCompare (x : xs) (y : ys) =
+    let comparison = jokerCompare x y
+     in if comparison == EQ
+          then jokerCompare xs ys
+          else comparison
+
+-- |
+-- >>> Hand [K,K,K,K,K]  `compare` Hand [A,A,A,A,A]
+-- LT
+--
+-- >>> Hand [K,K,K,K,A] `compare` Hand [T,T,T,T,T]
+-- LT
+instance Ord Hand where
+  compare :: Hand -> Hand -> Ordering
+  compare (Hand cards1) (Hand cards2) =
+    case comparing handType cards1 cards2 of
+      EQ -> cards1 `compare` cards2
+      x -> x
+
+instance JokerOrd Hand where
+  jokerCompare :: Hand -> Hand -> Ordering
+  jokerCompare (Hand cards1) (Hand cards2) =
+    case comparing jokerHandType cards1 cards2 of
+      EQ -> jokerCompare cards1 cards2
+      x -> x
+
+type Bid = Int
+
+readInput :: IO [(Hand, Bid)]
+readInput = do
+  input <- getContents
+  case readP_to_S inputParser input of
+    [] -> error "Parser failed"
+    [(parsed, "")] -> pure parsed
+    xs -> error $ "Parser failed: " <> show xs
+
+cardParser :: ReadP Card
+cardParser =
+  satisfy (`elem` "23456789TJQKA") <&> \case
+    '2' -> C2
+    '3' -> C3
+    '4' -> C4
+    '5' -> C5
+    '6' -> C6
+    '7' -> C7
+    '8' -> C8
+    '9' -> C9
+    'T' -> T
+    'J' -> J
+    'Q' -> Q
+    'K' -> K
+    'A' -> A
+    c -> error $ "impossible card: " <> [c]
+
+handParser :: ReadP Hand
+handParser =
+  Hand <$> replicateM 5 cardParser
+
+bidParser :: ReadP Bid
+bidParser = do
+  read <$> munch1 isDigit
+
+lineParser :: ReadP (Hand, Int)
+lineParser = do
+  h <- handParser
+  skipSpaces
+  b <- bidParser
+  pure (h, b)
+
+inputParser :: ReadP [(Hand, Int)]
+inputParser = do
+  sepBy1 lineParser (char '\n') <* eof

input/day7-eg

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