3 -- import Data.Text (Text)
4 -- import qualified Data.Text as T
5 import qualified Data.Text.IO as TIO
7 import Data.Attoparsec.Text hiding (take)
8 -- import Data.Attoparsec.Combinator
9 import Control.Applicative
10 -- import Control.Applicative.Combinators
12 import qualified Data.Array.Unboxed as A
13 import Data.Array.Unboxed ((!))
14 import qualified Data.Map.Strict as M
15 import Data.Bool (bool)
16 import Data.List (delete)
17 import Control.Monad (guard, foldM)
20 type Coord = (Int, Int)
21 type Pixels = A.UArray Coord Bool
22 type Border = A.UArray Int Bool
29 type Arrangement = M.Map Coord Tile
34 do text <- TIO.readFile "data/advent20.txt"
35 let tiles = successfulParse text
36 let arrangeRMax = (floor $ sqrt @Double $ fromIntegral $ length tiles) - 1
37 let arrangement = arrangeTiles arrangeRMax tiles
38 let image = assembleImage arrangeRMax arrangement
39 seaMonster <- readSeaMonster
40 print $ part1 arrangeRMax arrangement
41 print $ part2 seaMonster image
44 part1 rMax arrangement
47 $ M.filterWithKey (isCorner rMax) arrangement
49 part2 seaMonster image = minimum $ map (countRoughness seaMonster) transImages
50 where imgTile = Tile 0 image
51 transImages = map pixels $ transforms imgTile
54 readSeaMonster :: IO Pixels
56 do text <- TIO.readFile "data/advent20seamonster.txt"
57 return $ case parseOnly pixelsP text of
58 Left _err -> A.listArray ((0, 0), (1, 1)) []
59 Right seaMonster -> seaMonster
62 isCorner _ (0, 0) _ = True
63 isCorner l (0, c) _ = c == l
64 isCorner l (r, 0) _ = r == l
65 isCorner l (r, c) _ = r == l && c == l
67 arrangeTiles :: Int -> [Tile] -> Arrangement
68 arrangeTiles rMax tiles = fst $ head $ foldM arrange (M.empty, tiles) locations
69 where locations = init $ scanl nextLoc (0, 0) tiles
70 nextLoc (r, c) _ = if c == rMax then (r + 1, 0) else (r, c + 1)
72 arrange :: (Arrangement, [Tile]) -> Coord -> [(Arrangement, [Tile])]
73 arrange (grid, tiles) (r, c) =
75 transTile <- transforms tile
76 guard $ if r == 0 then True else matchVertical tileAbove transTile
77 guard $ if c == 0 then True else matchHorizontal tileLeft transTile
78 return (M.insert (r, c) transTile grid, delete tile tiles)
79 where tileAbove = grid M.! (r - 1 , c)
80 tileLeft = grid M.! (r, c - 1)
83 matchHorizontal tile1 tile2 = (rightBorder tile1) == (leftBorder tile2)
84 matchVertical tile1 tile2 = (bottomBorder tile1) == (topBorder tile2)
87 topBorder :: Tile -> Border
88 topBorder Tile{..} = A.listArray (0, c1) [pixels!(0, c) | c <- [0..c1] ]
89 where (_, (_, c1)) = A.bounds pixels
91 bottomBorder :: Tile -> Border
92 bottomBorder Tile{..} = A.listArray (0, c1) [pixels!(r1, c) | c <- [0..c1] ]
93 where (_, (r1, c1)) = A.bounds pixels
95 leftBorder :: Tile -> Border
96 leftBorder Tile{..} = A.listArray (0, r1) [pixels!(r, 0) | r <- [0..r1] ]
97 where (_, (r1, _)) = A.bounds pixels
99 rightBorder :: Tile -> Border
100 rightBorder Tile{..} = A.listArray (0, r1) [pixels!(r, c1) | r <- [0..r1] ]
101 where (_, (r1, c1)) = A.bounds pixels
104 transforms :: Tile -> [Tile]
107 | r <- [id, tRotate, tRotate . tRotate, tRotate . tRotate . tRotate]
111 -- rotate quarter turn clockwise
112 tRotate tile = tile {pixels = pixels'}
113 where bs = pixels tile
114 (_, (r1, c1)) = A.bounds bs
115 pixels' = A.ixmap ((0, 0), (c1, r1)) rotateIndex bs
116 rotateIndex (r, c) = (r1 - c, r) -- how to get to the old index from the new one
118 tFlip tile = tile {pixels = pixels'}
119 where bs = pixels tile
120 (_, (r1, c1)) = A.bounds bs
121 pixels' = A.ixmap ((0, 0), (r1, c1)) flipIndex bs
122 flipIndex (r, c) = (r, c1 - c) -- how to get to the old index from the new one
125 assembleImage :: Int -> Arrangement -> Pixels
126 assembleImage arrangeRMax arrangement =
127 A.array ((0,0), (imageRMax, imageRMax)) imageElements
128 where (_, (tileRMax, _)) = A.bounds $ pixels $ arrangement M.! (0, 0)
130 imageRMax = tRM1 * (arrangeRMax + 1) - 1
132 do ar <- [0..arrangeRMax] -- arrangement row
133 ac <- [0..arrangeRMax]
134 tr <- [1..tRM1] -- tile pixels row
136 let px = (pixels $ arrangement M.! (ar, ac)) ! (tr, tc)
137 let ir = (ar * tRM1) + (tr - 1) -- assembled image row
138 let ic = (ac * tRM1) + (tc - 1)
139 return ((ir, ic), px)
142 countRoughness sm image = imPixels - (smPixels * nSeaMonsters)
143 where smPixels = countPixels sm
144 imPixels = countPixels image
145 nSeaMonsters = length $ findSeaMonsters sm image
147 countPixels :: Pixels -> Int
148 countPixels = length . filter (== True) . A.elems
150 findSeaMonsters :: Pixels -> Pixels -> [Coord]
151 findSeaMonsters sm image = [ (r, c)
152 | r <- [0..(imR - smR)]
153 , c <- [0..(imC - smC)]
154 , seaMonsterPresent sm image r c
156 where (_, (smR, smC)) = A.bounds sm
157 (_, (imR, imC)) = A.bounds image
159 seaMonsterPresent sm image dr dc = all bothPresent $ A.indices sm
160 where bothPresent (r, c) = if (sm!(r, c))
161 then (image!(r + dr, c + dc))
165 showTile Tile{..} = show tId ++ "\n" ++ (showP pixels)
167 showP ps = unlines [[bool ' ' '\x2588' (ps!(r, c)) | c <- [0..cMax] ] | r <- [0..rMax]]
168 where (_, (rMax, cMax)) = A.bounds ps
169 -- sb b = bool '.' '#' b
171 -- -- Parse the input file
173 tilesP = tileP `sepBy` blankLines
175 blankLines = many endOfLine
177 tileP = Tile <$> ("Tile " *> decimal) <* ":" <* endOfLine <*> pixelsP
179 pixelsP = pixify <$> (pixelsRowP `sepBy` endOfLine)
180 pixelsRowP = many1 (satisfy (inClass " .#"))
182 pixify :: [String] -> Pixels
183 pixify rows = A.array ((0, 0), (nRows, nCols))
184 [ ((r, c), (rows!!r)!!c == '#')
188 where nRows = length rows - 1
189 nCols = (length $ head rows) - 1
192 -- successfulParse :: Text -> (Integer, [Maybe Integer])
193 successfulParse input =
194 case parseOnly tilesP input of
195 Left _err -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err