urghhh

day4.hs

@@ -0,0 +1,107 @@
+-- a haiku:
+-- this is some bad code
+-- but what more can you expect
+-- from a bad problem?
+
+import Data.Char (isDigit, isHexDigit)
+import Data.List (sort, nub)
+
+main :: IO ()
+main = do
+  raw <- readFile "day4.txt"
+  let ls = parse $ lines raw
+      ansA = length $ filter (== True) $ map solveA ls
+      ansB = length $ filter (== True) $ map solveB ls
+   in do 
+     putStrLn $ "day3a: " ++ (show ansA)
+     putStrLn $ "day3b: " ++ (show ansB)
+
+rtags :: [String]
+rtags = ["byr", "iyr", "eyr", "hgt", "hcl", "ecl", "pid"]
+
+extractTag :: String -> String
+extractTag [] = error "empty tag"
+extractTag s = takeWhile (/= ':') s
+
+extractValue :: String -> String
+extractValue [] = error "empty value"
+extractValue s = drop 1 $ dropWhile (/= ':') s
+
+applyAll :: [a] -> [(a -> b)] -> [b]
+applyAll [] [] = []
+applyAll (a:as) (f:fs) =
+  if length as /= length fs
+  then error "applyAll: lists must be same length"
+  else (f a) : (applyAll as fs)
+
+solveA :: [String] -> Bool
+solveA [] = False
+solveA s = foldr (&&) True $ map (`elem` tags) rtags
+  where
+    tags = map extractTag s
+
+solveB :: [String] -> Bool
+solveB [] = False
+solveB s = solveA s && 
+  (foldr (&&) True $ applyAll ls
+    [ byrValid
+    , eclValid
+    , eyrValid
+    , hclValid
+    , hgtValid
+    , iyrValid
+    , pidValid
+    ])
+  where
+    ls = (sort . nub) $ filter (\x -> elem (extractTag x) rtags) s
+
+yearValid :: Int -> Int -> String -> Bool
+yearValid l u s' = (length s) == 4
+           && (read s) >= l
+           && (read s) <= u
+  where
+    s = drop 1 $ dropWhile (/= ':') s'
+
+byrValid :: String -> Bool
+byrValid = yearValid 1920 2002
+
+iyrValid :: String -> Bool
+iyrValid = yearValid 2010 2020
+
+eyrValid :: String -> Bool
+eyrValid = yearValid 2020 2030
+
+eclValid :: String -> Bool
+eclValid s' = s `elem` ["amb","blu","brn","gry","grn","hzl","oth"]
+  where
+    s = drop 1 $ dropWhile (/= ':') s'
+
+pidValid :: String -> Bool
+pidValid s' = (length s) == 9 && all isDigit s
+  where
+    s = drop 1 $ dropWhile (/= ':') s'
+
+hclValid :: String -> Bool
+hclValid s' = h == '#' && all isHexDigit s
+  where
+    (h:s) = drop 1 $ dropWhile (/= ':') s'
+
+hgtValid :: String -> Bool
+hgtValid s' =
+  case unit of
+    "cm" -> val >= 150 && val <= 193
+    "in" -> val >= 59 && val <= 76
+    _ -> False
+  where
+    s = drop 1 $ dropWhile (/= ':') s'
+    (val,unit) = head $ (reads s :: [(Int,String)])
+
+parse :: [String] -> [[String]]
+parse [] = []
+parse s = parse' s [] []
+
+parse' :: [String] -> [String] -> [[String]] -> [[String]]
+parse' [] as bs = bs ++ [as]
+parse' (s:ss) as bs
+  | s == "" = parse' ss [] $ bs ++ [as]
+  | otherwise = parse' ss (as ++ (words s)) bs