1 {-# LANGUAGE NegativeLiterals #-}
2 {-# LANGUAGE FlexibleContexts #-}
3 {-# LANGUAGE OverloadedStrings #-}
4 {-# LANGUAGE TypeFamilies #-}
5 {-# LANGUAGE BangPatterns #-}
7 import Data.Text (Text)
8 import qualified Data.Text as T
9 import qualified Data.Text.IO as TIO
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
16 import qualified Data.Map.Strict as M
21 type Grid = M.Map (Int, Int) Bool
22 type ExplodedGrid = M.Map (Int, Int) Grid
24 data Rule = Rule Grid Grid deriving (Eq, Show)
26 rulePre (Rule g _) = g
27 rulePost (Rule _ g) = g
30 initialGrid = case parse gridP "" ".#./..#/###" of
37 text <- TIO.readFile "data/advent21.txt"
38 let rules = readRules text
39 print $ countLit $ nthApplication rules 5
40 print $ countLit $ nthApplication rules 18
43 -- Read the rules, and expand them to all equivalent left hand sides
44 readRules :: Text -> [Rule]
45 readRules = expandRules . successfulParse
48 expandRules :: [Rule] -> [Rule]
49 expandRules = concatMap expandRule
51 expandRule :: Rule -> [Rule]
52 expandRule rule = [Rule l (rulePost rule) | l <- allArrangements (rulePre rule)]
55 reflectH :: Grid -> Grid
56 reflectH g = M.fromList [((r, c) , M.findWithDefault False (rm - r, c) g) | r <- [0..rm], c <- [0..cm] ]
57 where (rm, cm) = bounds g
59 reflectV :: Grid -> Grid
60 reflectV g = M.fromList [((r, c) , M.findWithDefault False (r, cm - c) g) | r <- [0..rm], c <- [0..cm] ]
61 where (rm, cm) = bounds g
63 -- awkward naming to avoid clashing with Prelude
64 transposeG :: Grid -> Grid
65 transposeG g = M.fromList [((c, r) , M.findWithDefault False (r, c) g) | r <- [0..rm], c <- [0..cm] ]
66 where (rm, cm) = bounds g
69 -- Find all the arrangments of a grid, including reflection and rotation.
70 allArrangements :: Grid -> [Grid]
71 allArrangements grid = map (\f -> f grid) [ id
75 , reflectH . transposeG
76 , reflectV . transposeG
77 , reflectH . reflectV . transposeG
83 -- Count number of lit pixels
84 countLit :: Grid -> Int
85 countLit = M.size . M.filter id
87 -- apply the rules _n_ times
88 nthApplication :: [Rule] -> Int -> Grid
89 nthApplication rules n = (!! n) $ iterate (applyOnce rules) initialGrid
91 -- Apply one step of the expansion
92 applyOnce :: [Rule] -> Grid -> Grid
93 applyOnce rules g = contractExploded $ M.map (apply rules) $ explodeGrid g
95 -- find the appropriate rule and apply it to a grid
96 apply :: [Rule] -> Grid -> Grid
97 apply rules grid = rulePost thisRule
98 where ri = head $ findIndices (\r -> rulePre r == grid) rules
102 -- create the appropriate subgrids of a grid
103 explodeGrid :: Grid -> ExplodedGrid
104 explodeGrid g = if (rm + 1) `rem` 2 == 0
105 then explodeGrid' 2 g
106 else explodeGrid' 3 g
107 where (rm, _cm) = bounds g
109 explodeGrid' :: Int -> Grid -> ExplodedGrid
110 explodeGrid' n g = M.fromList [((bigR, bigC), subGrid n g bigR bigC) | bigR <- [0..bigRm], bigC <- [0..bigCm]]
111 where (rm, cm) = bounds g
112 bigRm = (rm + 1) `div` n - 1
113 bigCm = (cm + 1) `div` n - 1
116 subGrid :: Int -> Grid -> Int -> Int -> Grid
117 subGrid n g bigR bigC = M.fromList [ ((r, c),
118 M.findWithDefault False (r + rStep, c + cStep) g)
119 | r <- [0..(n - 1)], c <- [0..(n - 1)]
121 where rStep = bigR * n
124 -- merge a set of subgrids into one
125 contractExploded :: ExplodedGrid -> Grid
126 contractExploded gs = foldl1 (>|<) $ map (foldl1 (>-<)) rows
127 where rows = explodedRows gs
129 -- find the rows of an exploded grid
130 explodedRows :: ExplodedGrid -> [ExplodedGrid]
131 explodedRows eg = [M.filterWithKey (\(r, _) _ -> r == row) eg | row <- [0..rowMax] ]
132 where (rowMax, _) = bounds eg
134 -- merge two grids horizontally
135 (>-<) :: Grid -> Grid -> Grid
136 (>-<) g1 g2 = M.union g1 g2'
137 where (_, cm) = bounds g1
138 g2' = M.mapKeys (\(r, c) -> (r, c + cm + 1)) g2
140 -- merge two grids vertically
141 (>|<) :: Grid -> Grid -> Grid
142 (>|<) g1 g2 = M.union g1 g2'
143 where (rm, _) = bounds g1
144 g2' = M.mapKeys (\(r, c) -> (r + rm + 1, c)) g2
149 bounds :: M.Map (Int, Int) a -> (Int, Int)
150 bounds grid = (maximum $ map fst $ M.keys grid, maximum $ map snd $ M.keys grid)
153 showGrid :: Grid -> String
154 showGrid g = unlines [[showGChar $ M.findWithDefault False (r, c) g |
155 c <- [0..cm] ] | r <- [0..rm] ]
156 where (rm, cm) = bounds g
158 showGChar False = '.'
162 -- really persuade Megaparsec not to include newlines in how it consume spaces.
163 onlySpace = (char ' ') <|> (char '\t')
166 sc = L.space (skipSome onlySpace) CA.empty CA.empty
170 ruleJoin = symbol "=>"
172 present = id True <$ symbol "#"
173 absent = id False <$ symbol "."
175 rulesP = ruleP `sepBy` space
176 ruleP = Rule <$> gridP <* ruleJoin <*> gridP
178 gridP = gridify <$> rowP `sepBy` rowSep
179 where gridify g = M.fromList $ concat
180 [map (\(c, v) -> ((r, c), v)) nr |
182 [zip [0..] r | r <- g]]
185 rowP = some (present <|> absent)
187 successfulParse :: Text -> [Rule]
188 successfulParse input =
189 case parse rulesP "input" input of
191 Right instructions -> instructions