From c0962f9acd1475b686917894431585c01459ccde Mon Sep 17 00:00:00 2001
From: Maciej Jur <maciej@kamoshi.org>
Date: Thu, 7 Dec 2023 20:54:26 +0100
Subject: [PATCH] haskell: 2023 07

---
 2023/haskell/aoc2023.cabal      |   1 +
 2023/haskell/app/Main.hs        |   7 ++-
 2023/haskell/solutions/Day07.hs | 106 ++++++++++++++++++++++++++++++++
 2023/haskell/tests/Main.hs      |  17 +++++
 4 files changed, 128 insertions(+), 3 deletions(-)
 create mode 100644 2023/haskell/solutions/Day07.hs

diff --git a/2023/haskell/aoc2023.cabal b/2023/haskell/aoc2023.cabal
index 158463b..42452b9 100644
--- a/2023/haskell/aoc2023.cabal
+++ b/2023/haskell/aoc2023.cabal
@@ -24,6 +24,7 @@ library
     Day04
     Day05
     Day06
+    Day07
 
   -- other-modules:
 
diff --git a/2023/haskell/app/Main.hs b/2023/haskell/app/Main.hs
index fcb4f2f..8e6afaf 100644
--- a/2023/haskell/app/Main.hs
+++ b/2023/haskell/app/Main.hs
@@ -7,7 +7,8 @@ import Utils (readInput)
 --import qualified Day03
 --import qualified Day04
 --import qualified Day05
-import qualified Day06
+--import qualified Day06
+import qualified Day07
 
 
 run :: (Show b, Show c)
@@ -32,5 +33,5 @@ main = do
   --run 3 Day03.parse Day03.solveA Day03.solveB
   --run 4 Day04.parse Day04.solveA Day04.solveB
   --run 5 Day05.parse Day05.solveA Day05.solveB
-  run 6 Day06.parse Day06.solveA Day06.solveB
-  pure ()
+  --run 6 Day06.parse Day06.solveA Day06.solveB
+  run 7 Day07.parse Day07.solveA Day07.solveB
diff --git a/2023/haskell/solutions/Day07.hs b/2023/haskell/solutions/Day07.hs
new file mode 100644
index 0000000..e2c1688
--- /dev/null
+++ b/2023/haskell/solutions/Day07.hs
@@ -0,0 +1,106 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Day07 (parse, solveA, solveB) where
+
+import Data.Void (Void)
+import Data.Char (isDigit, digitToInt)
+import Data.Text (Text)
+import Data.List (sort, find, sortBy)
+import Data.Function (on)
+import Data.Bifunctor (first, Bifunctor (bimap))
+import Text.Megaparsec (Parsec, errorBundlePretty, runParser, many, eof)
+import Text.Megaparsec.Char (alphaNumChar, space)
+import Text.Megaparsec.Char.Lexer (decimal)
+import Control.Monad (join)
+
+
+data Card = X | Plain Int | T | J | Q | K | A
+  deriving (Eq, Ord, Read, Show)
+
+type Hand = [Card]
+type Play = (Hand, Int)
+
+data HandType = High | OnePair | TwoPair | Three | Full | Four | Five
+  deriving (Eq, Ord, Show)
+
+type Parser = Parsec Void Text
+
+
+parse :: Text -> Either String [Play]
+parse = first errorBundlePretty . runParser plays ""
+  where
+    card :: Char -> Card
+    card c
+      | isDigit c = Plain $ digitToInt c
+      | otherwise = read $ pure c
+    play :: Parser Play
+    play = do
+      cs  <- map card <$> many alphaNumChar
+      space
+      bet <- decimal
+      space
+      return (cs, bet)
+    plays :: Parser [Play]
+    plays = many play <* eof
+
+spansBy :: (a -> a -> Bool) -> [a] -> [[a]]
+spansBy = helper []
+  where
+    helper :: [[a]] -> (a -> a -> Bool) -> [a] -> [[a]]
+    helper acc        _ []     = reverse . map reverse $ acc
+    helper []         p (x:xs) = helper [[x]] p xs
+    helper acc@(a:as) p (x:xs) =
+      if p (head a) x
+      then helper ((x:a):as) p xs
+      else helper ([x]:acc)  p xs
+
+group :: Hand -> [[Card]]
+group = spansBy (==) . sort
+
+classify :: Hand -> HandType
+classify cs
+    | has [5]    = Five
+    | has [4]    = Four
+    | has [3, 2] = Full
+    | has [3]    = Three
+    | count 2 2  = TwoPair
+    | has [2]    = OnePair
+    | otherwise  = High
+    where
+      sizes :: [Int]
+      sizes = map length . group $ cs
+      has :: [Int] -> Bool
+      has   = all (`elem` sizes)
+      count :: Int -> Int -> Bool
+      count n = (==) . length . filter (n==) $ sizes
+
+withType :: Play -> (HandType, Play)
+withType = first (classify . fst) . join (,)
+
+score :: Int -> Play -> Int
+score = flip $ (*) . snd
+
+solveA :: [Play] -> Int
+solveA = sum . zipWith score [1..] . map snd . sort . map withType
+
+classify' :: [Card] -> HandType
+classify' cs =
+  let counts = map (bimap length head . join (,)) . spansBy (==) . sort $ cs
+      jokers = maybe 0 fst . find ((J ==) . snd) $ counts
+      others = sortBy (flip compare `on` fst) . filter ((J /=) . snd) $ counts
+  in case others of
+    []              -> Five
+    ((n, c) : rest) -> classify . concatMap (uncurry replicate) $ (n + jokers, c) : rest
+
+erase :: Card -> [Card] -> [Card]
+erase e = helper
+  where
+    helper [] = []
+    helper (c:cs)
+      | e == c    = X : helper cs
+      | otherwise = c : helper cs
+
+withType' :: Play -> (HandType, Play)
+withType' = bimap (classify' . fst) (first (erase J)) . join (,)
+
+solveB :: [Play] -> Int
+solveB = sum . zipWith score [1..] . map snd . sort . map withType'
diff --git a/2023/haskell/tests/Main.hs b/2023/haskell/tests/Main.hs
index fe45a01..fcb5573 100644
--- a/2023/haskell/tests/Main.hs
+++ b/2023/haskell/tests/Main.hs
@@ -9,6 +9,7 @@ import qualified Day03
 import qualified Day04
 import qualified Day05
 import qualified Day06
+import qualified Day07
 
 
 day01 :: Test
@@ -140,6 +141,21 @@ day06 =
       "Time:      7  15   30\n\
       \Distance:  9  40  200\n"
 
+day07 :: Test
+day07 =
+  let parsed = Day07.parse input
+  in TestList
+    [ TestCase $ assertEqual "A" (Right 6440) (Day07.solveA <$> parsed)
+    , TestCase $ assertEqual "B" (Right 5905) (Day07.solveB <$> parsed)
+    ]
+  where
+    input =
+      "32T3K 765\n\
+      \T55J5 684\n\
+      \KK677 28\n\
+      \KTJJT 220\n\
+      \QQQJA 483\n"
+
 tests :: Test
 tests = TestList
   [ TestLabel "day01" day01
@@ -148,6 +164,7 @@ tests = TestList
   , TestLabel "day04" day04
   , TestLabel "day05" day05
   , TestLabel "day06" day06
+  , TestLabel "day07" day07
   ]
 
 main :: IO ()