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 -- import Data.Either (fromRight)
  19
  20
  21 type Coord = (Int, Int)
  22 type Pixels = A.UArray Coord Bool
  23 type Border = A.UArray Int Bool
  24
  25 data Tile = Tile
  26   { tId :: Integer
  27   , pixels :: Pixels
  28   } deriving (Show, Eq)
  29
  30 type Arrangement = M.Map Coord Tile
  31
  32
  33 main :: IO ()
  34 main =
  35   do  text <- TIO.readFile "data/advent20.txt"
  36       let tiles = successfulParse text
  37       let arrangeRMax = (floor $ sqrt @Double $ fromIntegral $ length tiles) - 1
  38       let arrangement = arrangeTiles arrangeRMax tiles
  39       let image = assembleImage arrangeRMax arrangement
  40       seaMonster <- readSeaMonster
  41       print $ part1 arrangeRMax arrangement
  42       print $ part2 seaMonster image
  43
  44
  45 part1 rMax arrangement
  46   = product
  47   $ M.elems $ M.map tId
  48   $ M.filterWithKey (isCorner rMax) arrangement
  49
  50 part2 seaMonster image = minimum $ map (countRoughness seaMonster) transImages
  51   where imgTile = Tile 0 image
  52         transImages = map pixels $ transforms imgTile
  53
  54
  55 readSeaMonster :: IO Pixels
  56 readSeaMonster =
  57   do text <- TIO.readFile "data/advent20seamonster.txt"
  58      return $ case parseOnly pixelsP text of
  59       Left  _err -> A.listArray ((0, 0), (1, 1)) []
  60       Right seaMonster -> seaMonster
  61
  62
  63 isCorner _ (0, 0) _ = True
  64 isCorner l (0, c) _ = c == l
  65 isCorner l (r, 0) _ = r == l
  66 isCorner l (r, c) _ = r == l && c == l
  67
  68 arrangeTiles :: Int -> [Tile] -> Arrangement
  69 arrangeTiles rMax tiles = fst $ head $ foldM arrange (M.empty, tiles) locations
  70   where locations = init $ scanl nextLoc (0, 0) tiles
  71         nextLoc (r, c) _ = if c == rMax then (r + 1, 0) else (r, c + 1)
  72         -- (arrangement, _) = head $ foldM arrange (M.empty, tiles) locations
  73
  74 arrange :: (Arrangement, [Tile]) -> Coord -> [(Arrangement, [Tile])]
  75 arrange (grid, tiles) (r, c) =
  76   do  tile <- tiles
  77       transTile <- transforms tile
  78       guard $ if r == 0 then True else matchVertical tileAbove transTile
  79       guard $ if c == 0 then True else matchHorizontal tileLeft transTile
  80       return (M.insert (r, c) transTile grid, delete tile tiles)
  81   where tileAbove = grid M.! (r - 1 ,  c)
  82         tileLeft = grid M.! (r, c - 1)
  83
  84
  85 matchHorizontal tile1 tile2 = (rightBorder tile1) == (leftBorder tile2)
  86 matchVertical tile1 tile2 = (bottomBorder tile1) == (topBorder tile2)
  87
  88
  89 topBorder :: Tile -> Border
  90 topBorder Tile{..} = A.listArray (0, c1) [pixels!(0, c) | c <- [0..c1] ]
  91   where (_, (_, c1)) = A.bounds pixels
  92
  93 bottomBorder :: Tile -> Border
  94 bottomBorder Tile{..} = A.listArray (0, c1) [pixels!(r1, c) | c <- [0..c1] ]
  95   where (_, (r1, c1)) = A.bounds pixels
  96
  97 leftBorder :: Tile -> Border
  98 leftBorder Tile{..} = A.listArray (0, r1) [pixels!(r, 0) | r <- [0..r1] ]
  99   where (_, (r1, _)) = A.bounds pixels
 100
 101 rightBorder :: Tile -> Border
 102 rightBorder Tile{..} = A.listArray (0, r1) [pixels!(r, c1) | r <- [0..r1] ]
 103   where (_, (r1, c1)) = A.bounds pixels
 104
 105
 106 transforms :: Tile -> [Tile]
 107 transforms tile =
 108   [ r $ f tile
 109   | r <- [id, tRotate, tRotate . tRotate, tRotate . tRotate . tRotate]
 110   , f <- [id, tFlip]
 111   ]
 112
 113 -- rotate quarter turn clockwise
 114 tRotate tile = tile {pixels = pixels'}
 115   where bs = pixels tile
 116         (_, (r1, c1)) = A.bounds bs
 117         pixels' = A.ixmap ((0, 0), (c1, r1)) rotateIndex bs
 118         rotateIndex (r, c) = (r1 - c, r) -- how to get to the old index from the new one
 119
 120 tFlip tile = tile {pixels = pixels'}
 121   where bs = pixels tile
 122         (_, (r1, c1)) = A.bounds bs
 123         pixels' = A.ixmap ((0, 0), (r1, c1)) flipIndex bs
 124         flipIndex (r, c) = (r, c1 - c) -- how to get to the old index from the new one
 125
 126
 127 assembleImage :: Int -> Arrangement -> Pixels
 128 assembleImage arrangeRMax arrangement =
 129     A.array ((0,0), (imageRMax, imageRMax)) imageElements
 130   where (_, (tileRMax, _)) = A.bounds $ pixels $ arrangement M.! (0, 0)
 131         tRM1 = tileRMax - 1
 132         imageRMax = tRM1 * (arrangeRMax + 1) - 1
 133         imageElements =
 134           do  ar <- [0..arrangeRMax] -- arrangement row
 135               ac <- [0..arrangeRMax]
 136               tr <- [1..tRM1]        -- tile pixels row
 137               tc <- [1..tRM1]
 138               let px = (pixels $ arrangement M.! (ar, ac)) ! (tr, tc)
 139               let ir = (ar * tRM1) + (tr - 1) -- assembled image row
 140               let ic = (ac * tRM1) + (tc - 1)
 141               return ((ir, ic), px)
 142
 143
 144 countRoughness sm image = imPixels - (smPixels * nSeaMonsters)
 145   where smPixels = countPixels sm
 146         imPixels = countPixels image
 147         nSeaMonsters = length $ findSeaMonsters sm image
 148
 149 countPixels :: Pixels -> Int
 150 countPixels = length . filter (== True) . A.elems
 151
 152 findSeaMonsters :: Pixels -> Pixels -> [Coord]
 153 findSeaMonsters sm image = [ (r, c)
 154                            | r <- [0..(imR - smR)]
 155                            , c <- [0..(imC - smC)]
 156                            , seaMonsterPresent sm image r c
 157                            ]
 158   where (_, (smR, smC)) = A.bounds sm
 159         (_, (imR, imC)) = A.bounds image
 160
 161 seaMonsterPresent sm image dr dc = all bothPresent $ A.indices sm
 162   where bothPresent (r, c) = if (sm!(r, c))
 163                              then (image!(r + dr, c + dc))
 164                              else True
 165
 166
 167 showTile Tile{..} = show tId ++ "\n" ++ (showP pixels)
 168
 169 showP ps = unlines [[bool ' ' '\x2588' (ps!(r, c)) | c <- [0..cMax] ] | r <- [0..rMax]]
 170   where (_, (rMax, cMax)) = A.bounds ps
 171         -- sb b = bool '.' '#' b
 172
 173 -- -- Parse the input file
 174
 175 tilesP = tileP `sepBy` blankLines
 176
 177 blankLines = many endOfLine
 178
 179 tileP = Tile <$> ("Tile " *> decimal) <* ":" <* endOfLine <*> pixelsP
 180
 181 pixelsP = pixify <$> (pixelsRowP `sepBy` endOfLine)
 182 pixelsRowP = many1 (satisfy (inClass " .#"))
 183
 184 pixify :: [String] -> Pixels
 185 pixify rows = A.array ((0, 0), (nRows, nCols))
 186                       [ ((r, c), (rows!!r)!!c == '#')
 187                       | r <- [0..nRows]
 188                       , c <- [0..nCols]
 189                       ]
 190   where nRows = length rows - 1
 191         nCols = (length $ head rows) - 1
 192
 193
 194 -- successfulParse :: Text -> (Integer, [Maybe Integer])
 195 successfulParse input =
 196   case parseOnly tilesP input of
 197     Left  _err -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err
 198     Right tiles -> tiles