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 = (length differentQuads, steadyDiff, sum la, sum lb, sum lc, sum ld)-- (fromIntegral (sum la)) + steadyDiff * remainingGenerations
  33 part2 rules pots = (fromIntegral (sum lc)) + steadyDiff * remainingGenerations
  34     where rows = (iterate (\r -> applyRules rules r) pots)
  35           rowQuads = zip4 rows (drop 1 rows) (drop 2 rows) (drop 3 rows)
  36           sameDiffs (a, b, c, d) = length (nub [(sum a) - (sum b), (sum b) - (sum c), (sum c) - (sum d) ]) == 1
  37           differentQuads = takeWhile (not . sameDiffs) rowQuads
  38           (_la, _lb, lc, ld) = last differentQuads
  39           remainingGenerations = 50000000000 - (fromIntegral (length differentQuads)) - 1
  40           steadyDiff = fromIntegral $ (sum ld) - (sum lc)
  41
  42
  43 makeWorld :: Int -> [Bool] -> Pots
  44 makeWorld start = S.fromList . map fst . filter snd . zip [start..]
  45
  46 applyRuleAt :: [Rule] -> Int -> Pots -> (Int, Bool)
  47 applyRuleAt rules location pots = (location, result)
  48     where (Rule _ result) = head $ filter (\r -> matchRuleAt r location pots) rules
  49
  50 matchRuleAt :: Rule -> Int -> Pots -> Bool
  51 matchRuleAt (Rule pattern _) location pots = patternHere == potsHere
  52     where patternHere = makeWorld (location - 2) pattern
  53           potsHere = S.filter (\l -> abs (location - l) <= 2) pots
  54
  55
  56 applyRules :: [Rule] -> Pots -> Pots
  57 applyRules rules pots = S.fromList $ map fst $ filter snd potValues
  58     where start = S.findMin pots
  59           end = S.findMax pots
  60           potValues = map (\location -> applyRuleAt rules location pots) [(start-3)..(end+3)]
  61
  62 -- showPots pots = map (\i -> showPot i pots) [-10..110]
  63 --     where showPot i pots = if i `S.member` pots then '#' else '.'
  64
  65
  66 -- Parse the input file
  67
  68 type Parser = Parsec Void Text
  69
  70 sc :: Parser ()
  71 sc = L.space (skipSome spaceChar) CA.empty CA.empty
  72
  73 symb = L.symbol sc
  74 potP = (char '.' *> pure False) <|> (char '#' *> pure True)
  75
  76 initialPrefix = symb "initial state:"
  77 ruleSepP = symb "=>"
  78
  79 fileP = (,) <$> initialP <*> many ruleP
  80 initialP = initialPrefix *> many potP <* sc
  81 ruleP = Rule <$> ruleLHS <* ruleSepP <*> ruleRHS
  82 ruleLHS = count 5 potP <* sc
  83 ruleRHS = potP <* sc
  84
  85 successfulParse :: Text -> ([Bool], [Rule])
  86 successfulParse input =
  87         case parse fileP "input" input of
  88                 Left  _error -> ([], []) -- TIO.putStr $ T.pack $ parseErrorPretty err
  89                 Right world -> world