X-Git-Url: https://git.njae.me.uk/?a=blobdiff_plain;f=advent07%2FMain.hs;fp=advent07%2FMain.hs;h=6d326a4f545c08603210a8d9bc73de441fc2a7db;hb=c7364d4e2de33c97a720e1654e296d3f4c304756;hp=0000000000000000000000000000000000000000;hpb=80f3650ed9381e7e0045fe13852e4d3b1dc38083;p=advent-of-code-23.git

diff --git a/advent07/Main.hs b/advent07/Main.hs
new file mode 100644
index 0000000..6d326a4
--- /dev/null
+++ b/advent07/Main.hs
@@ -0,0 +1,113 @@
+-- Writeup at https://work.njae.me.uk/2023/12/07/advent-of-code-2023-day-07/
+
+import AoC
+import Data.Text (Text)
+import qualified Data.Text.IO as TIO
+import Data.Attoparsec.Text -- hiding (take)
+import Control.Applicative
+import Data.List
+
+data Card = Joker | Two | Three | Four | Five | Six | Seven | Eight | Nine | 
+            Ten | Jack | Queen | King | Ace deriving (Eq, Ord, Show)
+
+data HandClass = HighCard | OnePair | TwoPair | ThreeOfAKind | FullHouse | 
+                 FourOfAKind | FiveOfAKind deriving (Eq, Ord, Show)
+
+data Hand = Hand [Card] Int deriving (Eq, Ord, Show)
+data ClassifiedHand = CHand HandClass [Card] Int deriving (Eq, Ord, Show)
+
+type SignatureElement = (Int, [Card])
+type Signature = [SignatureElement]
+
+main :: IO ()
+main = 
+  do  dataFileName <- getDataFileName
+      text <- TIO.readFile dataFileName
+      let hands = successfulParse text
+      print $ part1 hands
+      print $ part2 hands
+      
+part1, part2 :: [Hand] -> Int
+part1 hands = sum $ fmap score rankedHands
+  where sortedHands = sort $ fmap classify hands
+        rankedHands = zip [1..] sortedHands
+        score (r, CHand _ _ bid) = r * bid
+
+part2 hands = part1 $ fmap enJoker hands
+
+enJoker :: Hand -> Hand
+enJoker (Hand cards bid) = Hand jCards bid
+  where jCards = replace Jack Joker cards
+
+replace :: Eq a => a -> a -> [a] -> [a]
+replace _ _ [] = []
+replace f t (x:xs) 
+  | x == f = t : replace f t xs
+  | otherwise = x : replace f t xs
+
+classify :: Hand -> ClassifiedHand
+classify (Hand cards bid) 
+  | isFiveOfAKind signature = CHand FiveOfAKind cards bid
+  | isFourOfAKind signature = CHand FourOfAKind cards bid
+  | isFullHouse signature = CHand FullHouse cards bid
+  | isThreeOfAKind signature = CHand ThreeOfAKind cards bid
+  | isTwoPair signature = CHand TwoPair cards bid
+  | isOnePair signature = CHand OnePair cards bid
+  | otherwise = CHand HighCard cards bid
+  where signature = sign cards
+
+sign :: [Card] -> Signature
+-- sign = reverse . sort . fmap (\g -> (length g, g)) . group . sort
+sign cards = addJokers nonJokerSigned (length jokers, jokers)
+  where (jokers, nonJokers) = partition (== Joker) cards
+        -- numJokers = length jokers
+        nonJokerSigned = reverse $ sort $ fmap (\g -> (length g, g)) $ 
+                           group $ sort nonJokers
+
+addJokers :: Signature -> SignatureElement -> Signature
+addJokers [] js = [js]
+addJokers ((n, cs):xs) (jn, js) = (n + jn, cs ++ js):xs
+
+isFiveOfAKind, isFourOfAKind, isFullHouse, isThreeOfAKind, isTwoPair, 
+  isOnePair :: Signature -> Bool
+isFiveOfAKind ((5, _):_) = True
+isFiveOfAKind _ = False
+
+isFourOfAKind ((4, _):_) = True
+isFourOfAKind _ = False
+
+isFullHouse ((3, _):(2, _):_) = True
+isFullHouse _ = False
+
+isThreeOfAKind ((3, _):_) = True
+isThreeOfAKind _ = False
+
+isTwoPair ((2, _):(2, _):_) = True
+isTwoPair _ = False
+
+isOnePair ((2, _):_) = True
+isOnePair _ = False
+
+-- isHighCard :: Signature -> Bool
+-- isHighCard _ = True
+
+-- Parse the input file
+
+handsP :: Parser [Hand]
+handP :: Parser Hand
+cardP :: Parser Card
+
+handsP = handP `sepBy` endOfLine
+handP = Hand <$> ((many1 cardP) <* space) <*> decimal
+
+cardP = (Two <$ "2") <|> (Three <$ "3") <|> (Four <$ "4") <|> 
+        (Five <$ "5") <|> (Six <$ "6") <|> (Seven <$ "7") <|> 
+        (Eight <$ "8") <|> (Nine <$ "9") <|> (Ten <$ "T") <|> 
+        (Jack <$ "J") <|> (Queen <$ "Q") <|> (King <$ "K") <|> 
+        (Ace <$ "A")
+
+successfulParse :: Text -> [Hand]
+successfulParse input = 
+  case parseOnly handsP input of
+    Left  _err -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err
+    Right matches -> matches