haskell: 2023 07
This commit is contained in:
parent
b405167551
commit
c0962f9acd
|
@ -24,6 +24,7 @@ library
|
|||
Day04
|
||||
Day05
|
||||
Day06
|
||||
Day07
|
||||
|
||||
-- other-modules:
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
106
2023/haskell/solutions/Day07.hs
Normal file
106
2023/haskell/solutions/Day07.hs
Normal file
|
@ -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'
|
|
@ -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 ()
|
||||
|
|
Loading…
Reference in a new issue