advent-of-code/2020/day4/day4.hs

import AoC

import Control.Applicative ((<|>))
import Control.Monad (guard, mfilter)
import Data.Char (isDigit)
import Data.List (intercalate)
import Data.Maybe (mapMaybe)
import Text.ParserCombinators.ReadP
import Text.Read (readMaybe)

data HeightUnit = Centimeter | Inch deriving (Show, Eq)
data ColourSpec = Amber | Blue | Brown | Gray | Green | Hazel | Other
                deriving (Show, Eq)

data Field = BirthYear Int
           | IssueYear Int
           | ExpirationYear Int
           | Height Int HeightUnit
           | HairColour String
           | EyeColour ColourSpec
           | PassportID String
           | CountryID String
           deriving (Show, Eq)

fieldSpecs :: [(String, ReadP Field)]
fieldSpecs = [ ("byr", BirthYear <$> parseYearIn 1920 2002)
             , ("iyr", IssueYear <$> parseYearIn 2010 2020)
             , ("eyr", ExpirationYear <$> parseYearIn 2020 2030)
             , ("hgt", do h <- parseNumber 2 <|> parseNumber 3
                          u <- parseHeightUnit
                          case u of
                            Inch -> guard $ within 59 76 h
                            Centimeter -> guard $ within 150 193 h
                          return $ Height h u)
             , ("hcl", char '#' >> HairColour <$> count 6 parseHexDigit)
             , ("ecl", EyeColour <$> parseColourSpec)
             , ("pid", PassportID <$> count 9 (satisfy $ const True))
             , ("cid", CountryID <$> munch1 (/= ' '))
             ]
    where parseYearIn = flip mfilter (parseNumber 4) .: within
          parseHexDigit = choice . map char $ ['0'..'9']++['a'..'f']

within :: Ord a => a -> a -> a -> Bool
within a b x = a <= x && x <= b

parseNumber :: (Num a, Read a) => Int -> ReadP a
parseNumber n = do
    Just digits <- readMaybe <$> count n (satisfy isDigit)
    return digits

parseHeightUnit :: ReadP HeightUnit
parseHeightUnit = choice [ string "cm" >> return Centimeter
                         , string "in" >> return Inch
                         ]

parseColourSpec :: ReadP ColourSpec
parseColourSpec = choice [ string "amb" >> return Amber
                          , string "blu" >> return Blue
                          , string "brn" >> return Brown
                          , string "gry" >> return Gray
                          , string "grn" >> return Green
                          , string "hzl" >> return Hazel
                          , string "oth" >> return Other
                          ]

parseKeyValue :: ReadP k -> ReadP v -> ReadP (k, v)
parseKeyValue kp vp = do k <- kp
                         char ':'
                         v <- vp
                         return (k, v)

parseFieldName :: ReadP String
parseFieldName = fmap fst $ choice
                    $ map (\(k, _) -> parseKeyValue (string k) (munch1 (/= ' ')))
                    $ fieldSpecs

parseField :: ReadP Field
parseField = fmap snd $ choice
                    $ map (\(k, v) -> parseKeyValue (string k) v)
                    $ fieldSpecs

spaceSeparated :: ReadP a -> ReadP [a]
spaceSeparated = flip sepBy (many1 $ char ' ')

parseFieldNames :: ReadP [String]
parseFieldNames = spaceSeparated parseFieldName

parsePassport :: ReadP [Field]
parsePassport = spaceSeparated parseField

hasAllRequiredFields :: String -> Bool
hasAllRequiredFields = maybe False containsAllFields . fieldNames
    where requiredFieldNames = ["byr", "iyr", "eyr", "hgt", "hcl", "ecl", "pid"]
          containsAllFields fields = all (`elem` fields) requiredFieldNames
          fieldNames = oneCompleteResult parseFieldNames

main = runAoC (filter hasAllRequiredFields . map (intercalate " ") . splitOnEmptyLines) (length) (length . mapMaybe (oneCompleteResult parsePassport))