day4: add haskell parser solution

2020/README.md

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

2020/day4/day4.hs

@@ -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