advent20/src/advent20.hs

   1 -- import Debug.Trace
   2
   3 -- import Data.Text (Text)
   4 -- import qualified Data.Text as T
   5 import qualified Data.Text.IO as TIO
   6
   7 import Data.Attoparsec.Text hiding (take)
   8 -- import Data.Attoparsec.Combinator
   9 import Control.Applicative
  10 -- import Control.Applicative.Combinators
  11
  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)
  18
  19
  20 type Coord = (Int, Int)
  21 type Pixels = A.UArray Coord Bool
  22 type Border = A.UArray Int Bool
  23
  24 data Tile = Tile
  25   { tId :: Integer
  26   , pixels :: Pixels
  27   } deriving (Show, Eq)
  28
  29 type Arrangement = M.Map Coord Tile
  30
  31
  32 main :: IO ()
  33 main =
  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
  42
  43
  44 part1 rMax arrangement
  45   = product
  46   $ M.elems $ M.map tId
  47   $ M.filterWithKey (isCorner rMax) arrangement
  48
  49 part2 seaMonster image = minimum $ map (countRoughness seaMonster) transImages
  50   where imgTile = Tile 0 image
  51         transImages = map pixels $ transforms imgTile
  52
  53
  54 readSeaMonster :: IO Pixels
  55 readSeaMonster =
  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
  60
  61
  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
  66
  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)
  71
  72 arrange :: (Arrangement, [Tile]) -> Coord -> [(Arrangement, [Tile])]
  73 arrange (grid, tiles) (r, c) =
  74   do  tile <- tiles
  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)
  81
  82
  83 matchHorizontal tile1 tile2 = (rightBorder tile1) == (leftBorder tile2)
  84 matchVertical tile1 tile2 = (bottomBorder tile1) == (topBorder tile2)
  85
  86
  87 topBorder :: Tile -> Border
  88 topBorder Tile{..} = A.listArray (0, c1) [pixels!(0, c) | c <- [0..c1] ]
  89   where (_, (_, c1)) = A.bounds pixels
  90
  91 bottomBorder :: Tile -> Border
  92 bottomBorder Tile{..} = A.listArray (0, c1) [pixels!(r1, c) | c <- [0..c1] ]
  93   where (_, (r1, c1)) = A.bounds pixels
  94
  95 leftBorder :: Tile -> Border
  96 leftBorder Tile{..} = A.listArray (0, r1) [pixels!(r, 0) | r <- [0..r1] ]
  97   where (_, (r1, _)) = A.bounds pixels
  98
  99 rightBorder :: Tile -> Border
 100 rightBorder Tile{..} = A.listArray (0, r1) [pixels!(r, c1) | r <- [0..r1] ]
 101   where (_, (r1, c1)) = A.bounds pixels
 102
 103
 104 transforms :: Tile -> [Tile]
 105 transforms tile =
 106   [ r $ f tile
 107   | r <- [id, tRotate, tRotate . tRotate, tRotate . tRotate . tRotate]
 108   , f <- [id, tFlip]
 109   ]
 110
 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
 117
 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
 123
 124
 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)
 129         tRM1 = tileRMax - 1
 130         imageRMax = tRM1 * (arrangeRMax + 1) - 1
 131         imageElements =
 132           do  ar <- [0..arrangeRMax] -- arrangement row
 133               ac <- [0..arrangeRMax]
 134               tr <- [1..tRM1]        -- tile pixels row
 135               tc <- [1..tRM1]
 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)
 140
 141
 142 countRoughness sm image = imPixels - (smPixels * nSeaMonsters)
 143   where smPixels = countPixels sm
 144         imPixels = countPixels image
 145         nSeaMonsters = length $ findSeaMonsters sm image
 146
 147 countPixels :: Pixels -> Int
 148 countPixels = length . filter (== True) . A.elems
 149
 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
 155                            ]
 156   where (_, (smR, smC)) = A.bounds sm
 157         (_, (imR, imC)) = A.bounds image
 158
 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))
 162                              else True
 163
 164
 165 showTile Tile{..} = show tId ++ "\n" ++ (showP pixels)
 166
 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
 170
 171 -- -- Parse the input file
 172
 173 tilesP = tileP `sepBy` blankLines
 174
 175 blankLines = many endOfLine
 176
 177 tileP = Tile <$> ("Tile " *> decimal) <* ":" <* endOfLine <*> pixelsP
 178
 179 pixelsP = pixify <$> (pixelsRowP `sepBy` endOfLine)
 180 pixelsRowP = many1 (satisfy (inClass " .#"))
 181
 182 pixify :: [String] -> Pixels
 183 pixify rows = A.array ((0, 0), (nRows, nCols))
 184                       [ ((r, c), (rows!!r)!!c == '#')
 185                       | r <- [0..nRows]
 186                       , c <- [0..nCols]
 187                       ]
 188   where nRows = length rows - 1
 189         nCols = (length $ head rows) - 1
 190
 191
 192 -- successfulParse :: Text -> (Integer, [Maybe Integer])
 193 successfulParse input =
 194   case parseOnly tilesP input of
 195     Left  _err -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err
 196     Right tiles -> tiles