advent07/Main.hs

   1 -- Writeup at https://work.njae.me.uk/2023/12/07/advent-of-code-2023-day-07/
   2
   3 import AoC
   4 import Data.Text (Text)
   5 import qualified Data.Text.IO as TIO
   6 import Data.Attoparsec.Text -- hiding (take)
   7 import Control.Applicative
   8 import Data.List
   9
  10 data Card = Joker | Two | Three | Four | Five | Six | Seven | Eight | Nine |
  11             Ten | Jack | Queen | King | Ace deriving (Eq, Ord, Show)
  12
  13 data HandClass = HighCard | OnePair | TwoPair | ThreeOfAKind | FullHouse |
  14                  FourOfAKind | FiveOfAKind deriving (Eq, Ord, Show)
  15
  16 data Hand = Hand [Card] Int deriving (Eq, Ord, Show)
  17 data ClassifiedHand = CHand HandClass [Card] Int deriving (Eq, Ord, Show)
  18
  19 type SignatureElement = (Int, [Card])
  20 type Signature = [SignatureElement]
  21
  22 main :: IO ()
  23 main =
  24   do  dataFileName <- getDataFileName
  25       text <- TIO.readFile dataFileName
  26       let hands = successfulParse text
  27       print $ part1 hands
  28       print $ part2 hands
  29
  30 part1, part2 :: [Hand] -> Int
  31 part1 hands = sum $ fmap score rankedHands
  32   where sortedHands = sort $ fmap classify hands
  33         rankedHands = zip [1..] sortedHands
  34         score (r, CHand _ _ bid) = r * bid
  35
  36 part2 = part1 . fmap enJoker
  37
  38 enJoker :: Hand -> Hand
  39 enJoker (Hand cards bid) = Hand jCards bid
  40   where jCards = replace Jack Joker cards
  41
  42 replace :: Eq a => a -> a -> [a] -> [a]
  43 replace f t = fmap (\x -> if x == f then t else x)
  44
  45 classify :: Hand -> ClassifiedHand
  46 classify (Hand cards bid)
  47   | isFiveOfAKind signature = CHand FiveOfAKind cards bid
  48   | isFourOfAKind signature = CHand FourOfAKind cards bid
  49   | isFullHouse signature = CHand FullHouse cards bid
  50   | isThreeOfAKind signature = CHand ThreeOfAKind cards bid
  51   | isTwoPair signature = CHand TwoPair cards bid
  52   | isOnePair signature = CHand OnePair cards bid
  53   | otherwise = CHand HighCard cards bid
  54   where signature = sign cards
  55
  56 sign :: [Card] -> Signature
  57 -- sign = reverse . sort . fmap (\g -> (length g, g)) . group . sort
  58 sign cards = addJokers nonJokerSigned (length jokers, jokers)
  59   where (jokers, nonJokers) = partition (== Joker) cards
  60         -- numJokers = length jokers
  61         nonJokerSigned = reverse $ sort $ fmap (\g -> (length g, g)) $
  62                            group $ sort nonJokers
  63
  64 addJokers :: Signature -> SignatureElement -> Signature
  65 addJokers [] js = [js]
  66 addJokers ((n, cs):xs) (jn, js) = (n + jn, cs ++ js):xs
  67
  68 isFiveOfAKind, isFourOfAKind, isFullHouse, isThreeOfAKind, isTwoPair,
  69   isOnePair :: Signature -> Bool
  70 isFiveOfAKind ((5, _):_) = True
  71 isFiveOfAKind _ = False
  72
  73 isFourOfAKind ((4, _):_) = True
  74 isFourOfAKind _ = False
  75
  76 isFullHouse ((3, _):(2, _):_) = True
  77 isFullHouse _ = False
  78
  79 isThreeOfAKind ((3, _):_) = True
  80 isThreeOfAKind _ = False
  81
  82 isTwoPair ((2, _):(2, _):_) = True
  83 isTwoPair _ = False
  84
  85 isOnePair ((2, _):_) = True
  86 isOnePair _ = False
  87
  88 -- isHighCard :: Signature -> Bool
  89 -- isHighCard _ = True
  90
  91 -- Parse the input file
  92
  93 handsP :: Parser [Hand]
  94 handP :: Parser Hand
  95 cardP :: Parser Card
  96
  97 handsP = handP `sepBy` endOfLine
  98 handP = Hand <$> ((many1 cardP) <* space) <*> decimal
  99
 100 cardP = (Two <$ "2") <|> (Three <$ "3") <|> (Four <$ "4") <|>
 101         (Five <$ "5") <|> (Six <$ "6") <|> (Seven <$ "7") <|>
 102         (Eight <$ "8") <|> (Nine <$ "9") <|> (Ten <$ "T") <|>
 103         (Jack <$ "J") <|> (Queen <$ "Q") <|> (King <$ "K") <|>
 104         (Ace <$ "A")
 105
 106 successfulParse :: Text -> [Hand]
 107 successfulParse input =
 108   case parseOnly handsP input of
 109     Left  _err -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err
 110     Right matches -> matches