day2: Shorten parsers a bit
This commit is contained in:
parent
ba418a6ded
commit
1311230bbb
2 changed files with 22 additions and 18 deletions
|
|
@ -1,6 +1,6 @@
|
||||||
module AoC.Parser (Parser, parseText, ws, linewise) where
|
module AoC.Parser (Parser, parseText, ws, linewise) where
|
||||||
|
|
||||||
import Text.Megaparsec (Parsec, parse, sepEndBy1)
|
import Text.Megaparsec (Parsec, errorBundlePretty, parse, sepEndBy1)
|
||||||
import Text.Megaparsec.Char (eol, space1)
|
import Text.Megaparsec.Char (eol, space1)
|
||||||
import Text.Megaparsec.Char.Lexer qualified as L
|
import Text.Megaparsec.Char.Lexer qualified as L
|
||||||
|
|
||||||
|
|
@ -9,7 +9,7 @@ type Parser = Parsec Void Text
|
||||||
parseText :: Parser a -> Text -> Either Text a
|
parseText :: Parser a -> Text -> Either Text a
|
||||||
parseText p t = case parse p "<inline>" t of
|
parseText p t = case parse p "<inline>" t of
|
||||||
Right a -> pure a
|
Right a -> pure a
|
||||||
Left e -> Left $ show e
|
Left e -> Left $ fromString $ errorBundlePretty e
|
||||||
|
|
||||||
-- skip whitespace
|
-- skip whitespace
|
||||||
ws :: Parser ()
|
ws :: Parser ()
|
||||||
|
|
|
||||||
|
|
@ -5,7 +5,7 @@ import AoC.Riddle
|
||||||
|
|
||||||
import Data.Map qualified as M
|
import Data.Map qualified as M
|
||||||
import Text.Megaparsec (choice, sepBy)
|
import Text.Megaparsec (choice, sepBy)
|
||||||
import Text.Megaparsec.Char (char, space1, string)
|
import Text.Megaparsec.Char (char, string)
|
||||||
import Text.Megaparsec.Char.Lexer qualified as L
|
import Text.Megaparsec.Char.Lexer qualified as L
|
||||||
|
|
||||||
data Cube = Red | Green | Blue
|
data Cube = Red | Green | Blue
|
||||||
|
|
@ -24,28 +24,29 @@ pCube =
|
||||||
, Blue <$ string "blue"
|
, Blue <$ string "blue"
|
||||||
]
|
]
|
||||||
|
|
||||||
|
-- | Parse a single set of cubes
|
||||||
|
--
|
||||||
|
-- >>> parseText pCubes "3 green"
|
||||||
|
-- Right (Green,3)
|
||||||
pCubes :: Parser (Cube, Integer)
|
pCubes :: Parser (Cube, Integer)
|
||||||
pCubes = do
|
pCubes = flip (,) <$> L.decimal <* ws <*> pCube
|
||||||
n <- L.decimal
|
|
||||||
_ <- space1
|
|
||||||
c <- pCube
|
|
||||||
pure (c, n)
|
|
||||||
|
|
||||||
type Game = (Integer, [Round])
|
type Game = [Round]
|
||||||
|
|
||||||
|
-- | Parse a single Game
|
||||||
|
--
|
||||||
|
-- >>> parseText pGame "Game 1: 3 blue, 4 red; 1 red, 2 green, 6 blue; 2 green"
|
||||||
|
-- Right [fromList [(Red,4),(Blue,3)],fromList [(Red,1),(Green,2),(Blue,6)],fromList [(Green,2)]]
|
||||||
pGame :: Parser Game
|
pGame :: Parser Game
|
||||||
pGame = do
|
pGame = do
|
||||||
_ <- string "Game" >> ws
|
string "Game" >> ws >> (L.decimal :: Parser Integer) >> char ':' >> ws
|
||||||
n <- L.decimal
|
pRound `sepBy` (char ';' >> ws)
|
||||||
_ <- char ':' >> ws
|
|
||||||
rs <- pRound `sepBy` (char ';' >> ws)
|
|
||||||
pure (n, rs)
|
|
||||||
|
|
||||||
pPuzzle :: Parser [Game]
|
pPuzzle :: Parser [Game]
|
||||||
pPuzzle = linewise pGame
|
pPuzzle = linewise pGame
|
||||||
|
|
||||||
isGameValid :: Game -> Bool
|
isGameValid :: Game -> Bool
|
||||||
isGameValid (_, rounds) = all isRoundValid rounds
|
isGameValid = all isRoundValid
|
||||||
|
|
||||||
isRoundValid :: Round -> Bool
|
isRoundValid :: Round -> Bool
|
||||||
isRoundValid = getAll . M.foldMapWithKey (\c n -> All $ cubesPossible c n)
|
isRoundValid = getAll . M.foldMapWithKey (\c n -> All $ cubesPossible c n)
|
||||||
|
|
@ -56,17 +57,20 @@ cubesPossible Green = (<= 13)
|
||||||
cubesPossible Blue = (<= 14)
|
cubesPossible Blue = (<= 14)
|
||||||
|
|
||||||
minimumSet :: Game -> Round
|
minimumSet :: Game -> Round
|
||||||
minimumSet (_, rounds) = foldr (M.unionWith max) M.empty rounds
|
minimumSet = foldr (M.unionWith max) M.empty
|
||||||
|
|
||||||
|
-- | Calculate the 'power' of a round by multiplying everything together.
|
||||||
|
-- >>> power $ fromList [(Red, 2), (Green, 4)]
|
||||||
|
-- 8
|
||||||
power :: Round -> Integer
|
power :: Round -> Integer
|
||||||
power = product . M.elems
|
power = product
|
||||||
|
|
||||||
solve :: (MonadIO m) => Text -> m (Either Text Solution)
|
solve :: (MonadIO m) => Text -> m (Either Text Solution)
|
||||||
solve riddle = case parseText pPuzzle riddle of
|
solve riddle = case parseText pPuzzle riddle of
|
||||||
Right puzzle ->
|
Right puzzle ->
|
||||||
let
|
let
|
||||||
part1 :: Integer
|
part1 :: Integer
|
||||||
part1 = sum . fmap fst . filter isGameValid $ puzzle
|
part1 = sum . fmap fst . filter (\(_, g) -> isGameValid g) $ zip [1 ..] puzzle
|
||||||
|
|
||||||
part2 :: Integer
|
part2 :: Integer
|
||||||
part2 = sum . fmap (power . minimumSet) $ puzzle
|
part2 = sum . fmap (power . minimumSet) $ puzzle
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue