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)
  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 $ M.elems
  47   $ 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 $ fromRight (A.listArray ((0, 0), (1, 1)) []) $ parseOnly pixelsP text
  59      return $ case parseOnly pixelsP text of
  60       Left  _err -> A.listArray ((0, 0), (1, 1)) []
  61       Right seaMonster -> seaMonster
  62
  63
  64 isCorner _ (0, 0) _ = True
  65 isCorner l (0, c) _ = c == l
  66 isCorner l (r, 0) _ = r == l
  67 isCorner l (r, c) _ = r == l && c == l
  68
  69 arrangeTiles :: Int -> [Tile] -> Arrangement
  70 arrangeTiles rMax tiles = head $ arrange (0, 0) rMax M.empty tiles
  71
  72 arrange :: Coord -> Int -> Arrangement -> [Tile] -> [Arrangement]
  73 -- arrange h _ g ts | trace (show h ++ " " ++ show (M.map tId g) ++ " > " ++ show (length ts)) False = undefined
  74 arrange _ _ grid [] = return grid
  75 arrange (r, c) cMax grid tiles =
  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       arrange (r', c')
  81               cMax
  82               (M.insert (r, c) transTile grid)
  83               (delete tile tiles)
  84   where tileAbove = grid M.! (r - 1 ,  c)
  85         tileLeft = grid M.! (r, c - 1)
  86         (r', c') = if c == cMax then (r + 1, 0) else (r, c + 1)
  87
  88
  89 matchHorizontal tile1 tile2 = (rightBorder tile1) == (leftBorder tile2)
  90 matchVertical tile1 tile2 = (bottomBorder tile1) == (topBorder tile2)
  91
  92
  93 topBorder :: Tile -> Border
  94 topBorder Tile{..} = A.listArray (0, c1) [pixels!(0, c) | c <- [0..c1] ]
  95   where (_, (_, c1)) = A.bounds pixels
  96
  97 bottomBorder :: Tile -> Border
  98 bottomBorder Tile{..} = A.listArray (0, c1) [pixels!(r1, c) | c <- [0..c1] ]
  99   where (_, (r1, c1)) = A.bounds pixels
 100
 101 leftBorder :: Tile -> Border
 102 leftBorder Tile{..} = A.listArray (0, r1) [pixels!(r, 0) | r <- [0..r1] ]
 103   where (_, (r1, _)) = A.bounds pixels
 104
 105 rightBorder :: Tile -> Border
 106 rightBorder Tile{..} = A.listArray (0, r1) [pixels!(r, c1) | r <- [0..r1] ]
 107   where (_, (r1, c1)) = A.bounds pixels
 108
 109
 110 transforms :: Tile -> [Tile]
 111 transforms tile =
 112   [ r $ f tile
 113   | r <- [id, tRotate, tRotate . tRotate, tRotate . tRotate . tRotate]
 114   , f <- [id, tFlip]
 115   ]
 116
 117 -- rotate quarter turn clockwise
 118 tRotate tile = tile {pixels = pixels'}
 119   where bs = pixels tile
 120         (_, (r1, c1)) = A.bounds bs
 121         pixels' = A.ixmap ((0, 0), (c1, r1)) rotateIndex bs
 122         rotateIndex (r, c) = (r1 - c, r) -- how to get to the old index from the new one
 123
 124 tFlip tile = tile {pixels = pixels'}
 125   where bs = pixels tile
 126         (_, (r1, c1)) = A.bounds bs
 127         pixels' = A.ixmap ((0, 0), (r1, c1)) flipIndex bs
 128         flipIndex (r, c) = (r, c1 - c) -- how to get to the old index from the new one
 129
 130
 131 assembleImage :: Int -> Arrangement -> Pixels
 132 assembleImage arrangeRMax arrangement =
 133     A.array ((0,0), (imageRMax, imageRMax)) imageElements
 134   where (_, (tileRMax, _)) = A.bounds $ pixels $ arrangement M.! (0, 0)
 135         tRM1 = tileRMax - 1
 136         imageRMax = tRM1 * (arrangeRMax + 1) - 1
 137         imageElements =
 138           do  ar <- [0..arrangeRMax] -- arrangement row
 139               ac <- [0..arrangeRMax]
 140               tr <- [1..tRM1]        -- tile pixels row
 141               tc <- [1..tRM1]
 142               let px = (pixels $ arrangement M.! (ar, ac)) ! (tr, tc)
 143               let ir = (ar * tRM1) + (tr - 1) -- assembled image row
 144               let ic = (ac * tRM1) + (tc - 1)
 145               return ((ir, ic), px)
 146
 147
 148 countRoughness sm image = imPixels - (smPixels * nSeaMonsters)
 149   where smPixels = countPixels sm
 150         imPixels = countPixels image
 151         nSeaMonsters = length $ findSeaMonsters sm image
 152
 153 countPixels :: Pixels -> Int
 154 countPixels = length . filter (== True) . A.elems
 155
 156 findSeaMonsters :: Pixels -> Pixels -> [Coord]
 157 findSeaMonsters sm image = [ (r, c)
 158                            | r <- [0..(imR - smR)]
 159                            , c <- [0..(imC - smC)]
 160                            , seaMonsterPresent sm image r c
 161                            ]
 162   where (_, (smR, smC)) = A.bounds sm
 163         (_, (imR, imC)) = A.bounds image
 164
 165 seaMonsterPresent sm image dr dc = all bothPresent $ A.indices sm
 166   where bothPresent (r, c) = if (sm!(r, c))
 167                              then (image!(r + dr, c + dc))
 168                              else True
 169
 170
 171 showTile Tile{..} = show tId ++ "\n" ++ (showP pixels)
 172
 173 showP ps = unlines [[bool ' ' '\x2588' (ps!(r, c)) | c <- [0..cMax] ] | r <- [0..rMax]]
 174   where (_, (rMax, cMax)) = A.bounds ps
 175         -- sb b = bool '.' '#' b
 176
 177 -- -- Parse the input file
 178
 179 tilesP = tileP `sepBy` blankLines
 180
 181 blankLines = many endOfLine
 182
 183 tileP = Tile <$> ("Tile " *> decimal) <* ":" <* endOfLine <*> pixelsP
 184
 185 pixelsP = pixify <$> (pixelsRowP `sepBy` endOfLine)
 186 pixelsRowP = many1 (satisfy (inClass " .#"))
 187
 188 pixify :: [String] -> Pixels
 189 pixify rows = A.array ((0, 0), (nRows, nCols))
 190                       [ ((r, c), (rows!!r)!!c == '#')
 191                       | r <- [0..nRows]
 192                       , c <- [0..nCols]
 193                       ]
 194   where nRows = length rows - 1
 195         nCols = (length $ head rows) - 1
 196
 197
 198 -- successfulParse :: Text -> (Integer, [Maybe Integer])
 199 successfulParse input =
 200   case parseOnly tilesP input of
 201     Left  _err -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err
 202     Right tiles -> tiles