src/advent12/advent12.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2
   3 import Data.Text (Text)
   4 import qualified Data.Text.IO as TIO
   5
   6 import Data.Void (Void)
   7
   8 import Text.Megaparsec
   9 import Text.Megaparsec.Char
  10 import qualified Text.Megaparsec.Char.Lexer as L
  11 import qualified Control.Applicative as CA
  12
  13 import Data.List
  14 import qualified Data.Set as S
  15
  16 type Pots = S.Set Int
  17 data Rule = Rule [Bool] Bool deriving (Eq, Show)
  18
  19 main :: IO ()
  20 main = do
  21     text <- TIO.readFile "data/advent12.txt"
  22     let (initial, rules) = successfulParse text
  23     let row = makeWorld 0 initial
  24     print $ part1 rules row
  25     print $ part2 rules row
  26
  27 part1 :: [Rule] -> Pots -> Int
  28 part1 rules row = sum $ (iterate (\r -> applyRules rules r) row)!!20
  29
  30
  31 part2 :: [Rule] -> Pots -> Integer
  32 part2 rules pots = (fromIntegral (sum lc)) + steadyDiff * remainingGenerations
  33     where rows = (iterate (\r -> applyRules rules r) pots)
  34           rowQuads = zip4 rows (drop 1 rows) (drop 2 rows) (drop 3 rows)
  35           sameDiffs (a, b, c, d) = length (nub [(sum a) - (sum b), (sum b) - (sum c), (sum c) - (sum d) ]) == 1
  36           differentQuads = takeWhile (not . sameDiffs) rowQuads
  37           (_la, _lb, lc, ld) = last differentQuads
  38           remainingGenerations = 50000000000 - (fromIntegral (length differentQuads)) - 1
  39           steadyDiff = fromIntegral $ (sum ld) - (sum lc)
  40
  41
  42 makeWorld :: Int -> [Bool] -> Pots
  43 makeWorld start = S.fromList . map fst . filter snd . zip [start..]
  44
  45 applyRuleAt :: [Rule] -> Int -> Pots -> (Int, Bool)
  46 applyRuleAt rules location pots = (location, result)
  47     where (Rule _ result) = head $ filter (\r -> matchRuleAt r location pots) rules
  48
  49 matchRuleAt :: Rule -> Int -> Pots -> Bool
  50 matchRuleAt (Rule pattern _) location pots = patternHere == potsHere
  51     where patternHere = makeWorld (location - 2) pattern
  52           potsHere = S.filter (\l -> abs (location - l) <= 2) pots
  53
  54
  55 applyRules :: [Rule] -> Pots -> Pots
  56 applyRules rules pots = S.fromList $ map fst $ filter snd potValues
  57     where start = S.findMin pots
  58           end = S.findMax pots
  59           potValues = map (\location -> applyRuleAt rules location pots) [(start-3)..(end+3)]
  60
  61 -- showPots pots = map (\i -> showPot i pots) [-10..110]
  62 --     where showPot i pots = if i `S.member` pots then '#' else '.'
  63
  64
  65 -- Parse the input file
  66
  67 type Parser = Parsec Void Text
  68
  69 sc :: Parser ()
  70 sc = L.space (skipSome spaceChar) CA.empty CA.empty
  71
  72 symb = L.symbol sc
  73 potP = (char '.' *> pure False) <|> (char '#' *> pure True)
  74
  75 initialPrefix = symb "initial state:"
  76 ruleSepP = symb "=>"
  77
  78 fileP = (,) <$> initialP <*> many ruleP
  79 initialP = initialPrefix *> many potP <* sc
  80 ruleP = Rule <$> ruleLHS <* ruleSepP <*> ruleRHS
  81 ruleLHS = count 5 potP <* sc
  82 ruleRHS = potP <* sc
  83
  84 successfulParse :: Text -> ([Bool], [Rule])
  85 successfulParse input =
  86         case parse fileP "input" input of
  87                 Left  _error -> ([], []) -- TIO.putStr $ T.pack $ parseErrorPretty err
  88                 Right world -> world