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 hands = part1 $ fmap enJoker hands
  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 _ _ [] = []
  44 replace f t (x:xs)
  45   | x == f = t : replace f t xs
  46   | otherwise = x : replace f t xs
  47
  48 classify :: Hand -> ClassifiedHand
  49 classify (Hand cards bid)
  50   | isFiveOfAKind signature = CHand FiveOfAKind cards bid
  51   | isFourOfAKind signature = CHand FourOfAKind cards bid
  52   | isFullHouse signature = CHand FullHouse cards bid
  53   | isThreeOfAKind signature = CHand ThreeOfAKind cards bid
  54   | isTwoPair signature = CHand TwoPair cards bid
  55   | isOnePair signature = CHand OnePair cards bid
  56   | otherwise = CHand HighCard cards bid
  57   where signature = sign cards
  58
  59 sign :: [Card] -> Signature
  60 -- sign = reverse . sort . fmap (\g -> (length g, g)) . group . sort
  61 sign cards = addJokers nonJokerSigned (length jokers, jokers)
  62   where (jokers, nonJokers) = partition (== Joker) cards
  63         -- numJokers = length jokers
  64         nonJokerSigned = reverse $ sort $ fmap (\g -> (length g, g)) $
  65                            group $ sort nonJokers
  66
  67 addJokers :: Signature -> SignatureElement -> Signature
  68 addJokers [] js = [js]
  69 addJokers ((n, cs):xs) (jn, js) = (n + jn, cs ++ js):xs
  70
  71 isFiveOfAKind, isFourOfAKind, isFullHouse, isThreeOfAKind, isTwoPair,
  72   isOnePair :: Signature -> Bool
  73 isFiveOfAKind ((5, _):_) = True
  74 isFiveOfAKind _ = False
  75
  76 isFourOfAKind ((4, _):_) = True
  77 isFourOfAKind _ = False
  78
  79 isFullHouse ((3, _):(2, _):_) = True
  80 isFullHouse _ = False
  81
  82 isThreeOfAKind ((3, _):_) = True
  83 isThreeOfAKind _ = False
  84
  85 isTwoPair ((2, _):(2, _):_) = True
  86 isTwoPair _ = False
  87
  88 isOnePair ((2, _):_) = True
  89 isOnePair _ = False
  90
  91 -- isHighCard :: Signature -> Bool
  92 -- isHighCard _ = True
  93
  94 -- Parse the input file
  95
  96 handsP :: Parser [Hand]
  97 handP :: Parser Hand
  98 cardP :: Parser Card
  99
 100 handsP = handP `sepBy` endOfLine
 101 handP = Hand <$> ((many1 cardP) <* space) <*> decimal
 102
 103 cardP = (Two <$ "2") <|> (Three <$ "3") <|> (Four <$ "4") <|>
 104         (Five <$ "5") <|> (Six <$ "6") <|> (Seven <$ "7") <|>
 105         (Eight <$ "8") <|> (Nine <$ "9") <|> (Ten <$ "T") <|>
 106         (Jack <$ "J") <|> (Queen <$ "Q") <|> (King <$ "K") <|>
 107         (Ace <$ "A")
 108
 109 successfulParse :: Text -> [Hand]
 110 successfulParse input =
 111   case parseOnly handsP input of
 112     Left  _err -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err
 113     Right matches -> matches