day4: add haskell parser solution

This commit is contained in:
Xiretza 2020-12-04 15:38:53 +01:00
parent c5aa52cb73
commit b911869704
Signed by: xiretza
GPG key ID: 17B78226F7139993
2 changed files with 116 additions and 1 deletions

View file

@ -9,4 +9,4 @@ https://adventofcode.com/2020/
| 1 | `**` | `**` | |
| 2 | `**` | | `**` |
| 3 | `**` | `**` | |
| 4 | `**` | | |
| 4 | `**` | `**` | |

115
day4/day4.hs Normal file
View file

@ -0,0 +1,115 @@
import Control.Applicative ((<|>))
import Control.Monad (guard, mfilter)
import Data.Char (isDigit)
import Data.Function (on)
import Data.List (groupBy, 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 <$> parseCoulourSpec)
, ("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']
(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
f .: g = (f .) . g
infixl 8 .:
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
]
parseCoulourSpec :: ReadP ColourSpec
parseCoulourSpec = 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
oneCompleteResult :: ReadP a -> String -> Maybe a
oneCompleteResult p s = case readP_to_S p s of
[(x, "")] -> Just x
_ -> Nothing
splitOnEmptyLines :: String -> [String]
splitOnEmptyLines = map (intercalate " ") . filter (not . any null) . groupBy ((==) `on` null) . lines
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 <* eof)
main = do
batches <- splitOnEmptyLines <$> readFile "input.txt"
let withRequiredFields = filter hasAllRequiredFields batches
print $ length withRequiredFields
let passports = mapMaybe (oneCompleteResult (parsePassport <* eof)) withRequiredFields
print $ length passports