aoc2020/day4.hs

-- 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 = map (concat . (map words)) $ split "" $ lines raw
      ansA = length $ filter (== True) $ map solveA ls
      ansB = length $ filter (== True) $ map solveB ls
   in do 
     putStrLn $ "day4a: " ++ (show ansA)
     putStrLn $ "day4b: " ++ (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)])

split :: Eq a => a -> [a] -> [[a]]
split _ [] = []
split d as = chunk : (split d rest)
  where
    chunk = takeWhile (/= d) as
    rest = drop 1 $ dropWhile (/= d) as