src/advent21/advent21.hs

   1 {-# LANGUAGE NegativeLiterals #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 {-# LANGUAGE TypeFamilies #-}
   5 {-# LANGUAGE BangPatterns #-}
   6
   7 import Data.Text (Text)
   8 import qualified Data.Text as T
   9 import qualified Data.Text.IO as TIO
  10
  11 import Text.Megaparsec hiding (State)
  12 import qualified Text.Megaparsec.Lexer as L
  13 import Text.Megaparsec.Text (Parser)
  14 import qualified Control.Applicative as CA
  15 -- import qualified Data.Functor as F
  16
  17 import qualified Data.Map.Strict as M
  18 import Data.Map.Strict ((!))
  19
  20 import Data.List
  21
  22
  23 type Grid = M.Map (Int, Int) Bool
  24 type ExplodedGrid = M.Map (Int, Int) Grid
  25
  26 data Rule = Rule Grid Grid deriving (Eq, Show)
  27
  28 rulePre (Rule g _) = g
  29 rulePost (Rule _ g) = g
  30
  31
  32 initialGrid = case parse gridP "" ".#./..#/###" of
  33                 Left _ -> M.empty
  34                 Right g -> g
  35
  36
  37 main :: IO ()
  38 main = do
  39         text <- TIO.readFile "data/advent21.txt"
  40         let rules = readRules text
  41         print $ countLit $ nthApplication rules 5
  42         print $ countLit $ nthApplication rules 18
  43
  44
  45 readRules :: Text -> [Rule]
  46 readRules = expandRules . successfulParse
  47
  48 expandRules = concatMap expandRule
  49 expandRule rule = [Rule l (rulePost rule) | l <- allArrangements (rulePre rule)]
  50
  51 reflectH g = M.fromList [((r, c) , M.findWithDefault False (rm - r, c) g) | r <- [0..rm], c <- [0..cm] ]
  52     where (rm, cm) = bounds g
  53
  54 reflectV g = M.fromList [((r, c) , M.findWithDefault False (r, cm - c) g) | r <- [0..rm], c <- [0..cm] ]
  55     where (rm, cm) = bounds g
  56
  57 transposeG g = M.fromList [((c, r) , M.findWithDefault False (r, c) g) | r <- [0..rm], c <- [0..cm] ]
  58     where (rm, cm) = bounds g
  59
  60 allArrangements grid = map (\f -> f grid) [ id
  61                                           , reflectH
  62                                           , reflectV
  63                                           , transposeG
  64                                           , reflectH . transposeG
  65                                           , reflectV . transposeG
  66                                           , reflectH . reflectV . transposeG
  67                                           , reflectV . reflectH
  68                                           ]
  69
  70
  71
  72
  73 countLit = M.size . M.filter id
  74
  75
  76 applyOnce rules g = contractExploded $ M.map (apply rules) $ explodeGrid g
  77
  78 nthApplication rules n = (!! n) $ iterate (applyOnce rules) initialGrid
  79
  80
  81
  82 apply rules grid = rulePost thisRule
  83     where ri = head $ findIndices (\r -> rulePre r == grid) rules
  84           thisRule = rules!!ri
  85
  86
  87 explodeGrid :: Grid -> ExplodedGrid
  88 explodeGrid g = if (rm + 1) `rem` 2 == 0
  89                 then explodeGrid' 2 g
  90                 else explodeGrid' 3 g
  91     where (rm, cm) = bounds g
  92
  93 contractExploded :: ExplodedGrid -> Grid
  94 contractExploded gs = foldl1 (>|<) $ map (foldl1 (>-<)) rows
  95     where rows = explodedRows gs
  96
  97
  98 explodeGrid' :: Int -> Grid -> ExplodedGrid
  99 explodeGrid' n g = M.fromList [((bigR, bigC), subGrid n g bigR bigC) | bigR <- [0..bigRm], bigC <- [0..bigCm]]
 100     where (rm, cm) = bounds g
 101           bigRm = (rm + 1) `div` n - 1
 102           bigCm = (cm + 1) `div` n - 1
 103
 104
 105 subGrid :: Int -> Grid -> Int -> Int -> Grid
 106 subGrid n g bigR bigC = M.fromList [ ((r, c),
 107                                       M.findWithDefault False (r + rStep, c + cStep) g)
 108                                    | r <- [0..(n - 1)], c <- [0..(n - 1)]
 109                                    ]
 110     where rStep = bigR * n
 111           cStep = bigC * n
 112
 113
 114 explodedRows eg = [M.filterWithKey (\(r, _) _ -> r == row) eg | row <- [0..rowMax] ]
 115     where (rowMax, _) = bounds eg
 116
 117 (>-<) g1 g2 = M.union g1 g2'
 118     where (_, cm) = bounds g1
 119           g2' = M.mapKeys (\(r, c) -> (r, c + cm + 1)) g2
 120
 121 (>|<) g1 g2 = M.union g1 g2'
 122     where (rm, _) = bounds g1
 123           g2' = M.mapKeys (\(r, c) -> (r + rm + 1, c)) g2
 124
 125
 126
 127
 128
 129 bounds :: M.Map (Int, Int) a -> (Int, Int)
 130 bounds grid = (maximum $ map fst $ M.keys grid, maximum $ map snd $ M.keys grid)
 131
 132
 133 showGrid g = unlines [[showGChar $ M.findWithDefault False (r, c) g |
 134                 c <- [0..cm] ] | r <- [0..rm] ]
 135     where (rm, cm) = bounds g
 136           showGChar True = '#'
 137           showGChar False = '.'
 138
 139
 140 onlySpace = (char ' ') <|> (char '\t')
 141
 142 sc :: Parser ()
 143 sc = L.space (skipSome onlySpace) CA.empty CA.empty
 144
 145 lexeme  = L.lexeme sc
 146
 147 symbol = L.symbol sc
 148 rowSep = symbol "/"
 149 ruleJoin = symbol "=>"
 150
 151 present = id True <$ symbol "#"
 152 absent = id False <$ symbol "."
 153
 154 rulesP = ruleP `sepBy` space
 155 ruleP = Rule <$> gridP <*> (ruleJoin *> gridP)
 156
 157 gridP = gridify <$> rowP `sepBy` rowSep
 158     where gridify g = M.fromList $ concat
 159                                     [map (\(c, v) -> ((r, c), v)) nr |
 160                                              (r, nr) <- zip [0..]
 161                                                             [zip [0..] r | r <- g]]
 162
 163
 164 rowP = some (present <|> absent)
 165
 166 successfulParse :: Text -> [Rule]
 167 successfulParse input =
 168         case parse rulesP "input" input of
 169                 Left  _error -> []
 170                 Right instructions  -> instructions