1 files changed, 82 insertions, 0 deletions

diff --git a/execs/Day04.hs b/execs/Day04.hs
new file mode 100644
index 0000000..04aacbb
--- /dev/null
+++ b/execs/Day04.hs
@@ -0,0 +1,82 @@
+module Main where
+
+import Text.ParserCombinators.Parsec
+import Text.Parsec.Char
+import Data.Either
+import Data.Maybe
+import Control.Monad
+import Data.List (sortOn)
+
+right (Right a) = a
+fields = [ "byr" , "iyr" , "eyr" , "hgt" , "hcl" , "ecl" , "pid" ] 
+
+block = cell `sepBy` oneOf " \n"
+cell = do
+    tag <- many lower
+    char ':'
+    rest <- many (alphaNum <|> char '#')
+    return (tag, rest)
+
+parseInput :: String -> Either ParseError [(String, String)]
+parseInput = parse block "input"
+
+assocGet s (l:ls) = if fst l == s
+                       then snd l
+                       else assocGet s ls
+
+doCheck :: [(String, String)] -> Bool
+doCheck ls = all (isJust . flip lookup ls) fields
+
+checkNum lower up s = p >= lower && p <= up
+    where p = read s :: Int
+byr = checkNum 1920 2002
+iyr = checkNum 2010 2020
+eyr = checkNum 2020 2030
+
+parseHeight :: Parser (Int, String)
+parseHeight = do
+    v <- many1 digit
+    unit <- choice $ map string ["cm", "in"]
+    return (read v, unit)
+hgt s = case parse parseHeight "hgt" s of
+          Right (v, "cm") -> v >= 150 && v <= 193
+          Right (v, "in") -> v >= 59 && v <= 76
+          _ -> False
+
+parseColor = char '#' >> many hexDigit
+hcl :: String -> Bool
+hcl s = case parse parseColor "hcl" s of
+          Right c -> length c == 6
+          Left _ -> False
+
+
+ecl :: String -> Bool
+ecl = flip elem ["amb", "blu", "brn", "gry", "grn", "hzl", "oth"]
+
+parsePid = replicateM 9 digit
+pid :: String -> Bool
+pid s = isRight $ parse parsePid "pid" s
+
+doValidity :: [(String, String)] -> Bool
+doValidity ls = all ((== True) . ($ ls)) [ byr . assocGet "byr"
+                                         , iyr . assocGet "iyr"
+                                         , eyr . assocGet "eyr"
+                                         , hgt . assocGet "hgt"
+                                         , hcl . assocGet "hcl"
+                                         , ecl . assocGet "ecl"
+                                         , pid . assocGet "pid"
+                                         ]
+
+parseLines :: [String] -> [String]
+parseLines allLines = unwords first : next
+  where (first, rest) = break null allLines
+        next = if null rest then [] else parseLines (tail rest)
+
+main :: IO ()
+main = do
+    n <- parseLines . lines <$> readFile "input/04"
+    let blocks = map (right . parseInput) n
+    print $ length $ filter (\p -> doCheck p && doValidity p) blocks
+    -- mapM_ print $ filter (\p -> doCheck p && doValidity p) $ map (sortOn fst) blocks
+    -- print $ length $ filter doCheck blocks
+    -- print $ length $ filter (\p -> doCheck p && doValidity p) $ map (sortOn fst) blocks