1 January 2021 ; tagged in: advent of code , haskell

Advent of Code 2020 day 20

Yak shaving and sea monsters

Advent of Code 2020 day 20

Day 20 was a lot of effort, in that there were a lot of moving parts, even though no single part was particularly difficult.

I'll start by getting the yak shaving out of the way, describing the data structures and some utility functions needed to express the problems and solutions. When I've done that, I can get into the meat of the tasks themselves.

Data types and utilities

There are a few things to name, to make life easier. Some Pixels are the grid of Boolean values that make up an image or sub-image. A Tile is one of the small images, consisting of the Pixels and the ID. ( Tiles don't record if they've been transformed: I considered storing that, but YAGNI led me to leave it out until it was necessary. It turns out, it wasn't necessary.) A Border is the one-dimensional strip of pixels on the edge of an image. An Arrangement is the layout of tiles to form the whole image.

I'm using unboxed, immutable arrays of Bools for the Pixels. Note that they contain their bounds, which means I don't need to keep passing around the sizes of things. I decided to use the (row, column) convention for addressing pixels, and use zer0-based indexing.

type Coord = (Int, Int)
type Pixels = A.UArray Coord Bool 
type Border = A.UArray Int Bool 

data Tile = Tile 
  { tId :: Integer
  , pixels :: Pixels 
  } deriving (Show, Eq)

type Arrangement = M.Map Coord Tile

Parsing the input isn't overly tricky, apart from the need to build the pixels by hand.

tilesP = tileP `sepBy` blankLines

blankLines = many endOfLine

tileP = Tile <$> ("Tile " *> decimal) <* ":" <* endOfLine <*> pixelsP

pixelsP = pixify <$> (pixelsRowP `sepBy` endOfLine)
pixelsRowP = many1 (satisfy (inClass " .#"))

pixify :: [String] -> Pixels
pixify rows = A.array ((0, 0), (nRows, nCols)) 
                      [ ((r, c), (rows!!r)!!c == '#')
                      | r <- [0..nRows]
                      , c <- [0..nCols]
  where nRows = length rows - 1
        nCols = (length $ head rows) - 1

I also created showTile and showP (show pixels) functions to aid debugging. They're not used in the final solution.

showTile Tile{..} = show tId ++ "\n" ++ (showP pixels)

showP ps = unlines [[bool ' ' '\x2588' (ps!(r, c)) | c <- [0..cMax] ] | r <- [0..rMax]]
  where (_, (rMax, cMax)) = A.bounds ps

Finding borders

From a tile, I need to find the borders of that tile's pixels. I do this with a list comprehension to find the indices I want, extract those pixels, and use listArray to build the Border.

topBorder :: Tile -> Border
topBorder Tile{..} = A.listArray (0, c1) [pixels!(0, c) | c <- [0..c1] ]
  where (_, (_, c1)) = A.bounds pixels

bottomBorder :: Tile -> Border
bottomBorder Tile{..} = A.listArray (0, c1) [pixels!(r1, c) | c <- [0..c1] ]
  where (_, (r1, c1)) = A.bounds pixels

leftBorder :: Tile -> Border
leftBorder Tile{..} = A.listArray (0, r1) [pixels!(r, 0) | r <- [0..r1] ]
  where (_, (r1, _)) = A.bounds pixels

rightBorder :: Tile -> Border
rightBorder Tile{..} = A.listArray (0, r1) [pixels!(r, c1) | r <- [0..r1] ]
  where (_, (r1, c1)) = A.bounds pixels

Matching tiles horizontally and vertically is a case of testing if the corresponding edges are equal.

matchHorizontal tile1 tile2 = (rightBorder tile1) == (leftBorder tile2)
matchVertical tile1 tile2 = (bottomBorder tile1) == (topBorder tile2)

Transforming images

All the transforms of an image require just rotation by 90⁰ and reflection, and then some composition of those operations. That means I need just two transformation functions. Each takes a Tile and returns a transformed Tile.

-- rotate quarter turn clockwise
tRotate tile = tile {pixels = pixels'}
  where bs = pixels tile
        (_, (r1, c1)) = A.bounds bs
        pixels' = A.ixmap ((0, 0), (c1, r1)) rotateIndex bs
        rotateIndex (r, c) = (r1 - c, r) -- how to get to the old index from the new one

tFlip tile = tile {pixels = pixels'}
  where bs = pixels tile
        (_, (r1, c1)) = A.bounds bs
        pixels' = A.ixmap ((0, 0), (r1, c1)) flipIndex bs
        flipIndex (r, c) = (r, c1 - c) -- how to get to the old index from the new one

The only wrinkle in these is the slightly odd formation of ixmap: it takes a function that, for a location in the new array, returns the corresponding location in the old array. That took me a while to figure out why my tRotate was rotation anticlockwise rather than clockwise.

From those, I can find all eight transforms of a tile by using a list comprehension. (I could have done something clever with iterate for the repeated rotations, but decided this was just as quick and more explicit.)

transforms :: Tile -> [Tile]
transforms tile = 
  [ r $ f tile
  | r <- [id, tRotate, tRotate . tRotate, tRotate . tRotate . tRotate]
  , f <- [id, tFlip]

Assembling the grid

I had a few options for this. Assembling tiles into an arrangement is a nondeterministic process, as I don't know which tile to place first. The List monad is the classic example of how to do that. I could have used an explicit search of tile placements (similar to last year's day 20). An explicit search could also use a heuristic (similar to last year's day 18, using A* search), such as the most-constrained-placement heuristic. That also suggested using a constraint satisfaction solver, as I did on day 16.

In the end, I thought I'd start with the simplest approach, the List monad, and see if that worked. It turns out, that was enough.

arrangeTiles takes the number of tiles in each dimension of the arrangement, and returns just one arrangement (there will be eight variants of each solution, one for each transform of the overall arrangement). It does this by folding the locations of the arrangement, with each step being the insertion of a tile at this location. But as I'm using a List monad, I use the monadic fold foldM. And note the use of init in the definition of locations to ensure I only fold over as many locations as are legal.

arrange does the work. Given a position and a state of the arrangement so far, it adds a tile to this position; the state of the arrangement is the pair of the overall arrangement and the tiles remaining. It picks an arbitrary tile of those available, an arbitrary arrangement of that tile, checks it matches the tiles above and to the left, then returns the updated arrangement. Not that it also deletes this tile from the tiles available, to ensure no tile is used twice.

arrangeTiles :: Int -> [Tile] -> Arrangement
arrangeTiles rMax tiles = fst $ head $ foldM arrange (M.empty, tiles) locations
  where locations = init $ scanl nextLoc (0, 0) tiles
        nextLoc (r, c) _ = if c == rMax then (r + 1, 0) else (r, c + 1)

arrange :: (Arrangement, [Tile]) -> Coord -> [(Arrangement, [Tile])]
arrange (grid, tiles) (r, c) = 
  do  tile <- tiles
      transTile <- transforms tile
      guard $ if r == 0 then True else matchVertical tileAbove transTile
      guard $ if c == 0 then True else matchHorizontal tileLeft transTile
      return (M.insert (r, c) transTile grid, delete tile tiles)
  where tileAbove = grid M.! (r - 1 ,  c)
        tileLeft = grid M.! (r, c - 1)

All that's left is to set up arrangeTiles and extract the IDs of the corners of the arrangements.

main :: IO ()
main = 
  do  text <- TIO.readFile "data/advent20.txt"
      let tiles = successfulParse text
      let arrangeRMax = (floor $ sqrt @Double $ fromIntegral $ length tiles) - 1
      let arrangement = arrangeTiles arrangeRMax tiles
      print $ part1 arrangeRMax arrangement

part1 rMax arrangement 
  = product 
  $ M.elems $ M.map tId 
  $ M.filterWithKey (isCorner rMax) arrangement

isCorner _ (0, 0) _ = True
isCorner l (0, c) _ = c == l
isCorner l (r, 0) _ = r == l
isCorner l (r, c) _ = r == l && c == l

Finding Sea Monsters

This involved a few stages:

  1. Read the sea monster image
  2. Assemble the complete image
  3. Find sea monsters in the image and hence the roughness remaining

And all of that on the possible transforms of the image, and picking the correct answer!

I stored the sea monster image as a file, and read and parse it in the same way as the tiles.

readSeaMonster :: IO Pixels
readSeaMonster = 
  do text <- TIO.readFile "data/advent20seamonster.txt"
     return $ case parseOnly pixelsP text of
      Left  _err -> A.listArray ((0, 0), (1, 1)) []
      Right seaMonster -> seaMonster

Assembling the image

Assembling the image involved walking over each pixel of each tile in the arrangement, calculating where it needs to go, then creating the image as Pixels. I did the assembly of the imageElements as another list monad, so that I could use let clauses for intermediate calculations which (hopefully) makes things easier to understand.

assembleImage :: Int -> Arrangement -> Pixels
assembleImage arrangeRMax arrangement = 
    A.array ((0,0), (imageRMax, imageRMax)) imageElements
  where (_, (tileRMax, _)) = A.bounds $ pixels $ arrangement M.! (0, 0)
        tRM1 = tileRMax - 1
        imageRMax = tRM1 * (arrangeRMax + 1) - 1
        imageElements = 
          do  ar <- [0..arrangeRMax] -- arrangement row
              ac <- [0..arrangeRMax]
              tr <- [1..tRM1]        -- tile pixels row
              tc <- [1..tRM1]
              let px = (pixels $ arrangement M.! (ar, ac)) ! (tr, tc)
              let ir = (ar * tRM1) + (tr - 1) -- assembled image row
              let ic = (ac * tRM1) + (tc - 1)
              return ((ir, ic), px)

Finding sea monsters

The idea is to slide the sea monster pixels across the image, to I overlay the sea monster in all the position it fits. At each position, I check whether there actually is a sea monster at this location. (This is essentially the idea of convolutions and kernel processing in image processing.) If I find a monster, findSeaMonsters returns its position (useful for testing).

There is a seaMonsterPresent if, for every pixel in the sea monster, that pixel is set and the underlying pixel in the image is also set.

findSeaMonsters :: Pixels -> Pixels -> [Coord]
findSeaMonsters sm image = [ (r, c) 
                           | r <- [0..(imR - smR)]
                           , c <- [0..(imC - smC)]
                           , seaMonsterPresent sm image r c
  where (_, (smR, smC)) = A.bounds sm
        (_, (imR, imC)) = A.bounds image

seaMonsterPresent sm image dr dc = all bothPresent $ A.indices sm
  where bothPresent (r, c) = if (sm!(r, c)) 
                             then (image!(r + dr, c + dc))
                             else True

For calculating the final roughness of the image, I assumed that the images of sea monsters don't overlap, so the number of pixels in sea monster images is the number of pixels in a sea monster times the number of monsters. That makes the roughness calculation a simple matter of subtraction.

countRoughness sm image = imPixels - (smPixels * nSeaMonsters)
  where smPixels = countPixels sm
        imPixels = countPixels image
        nSeaMonsters = length $ findSeaMonsters sm image

countPixels :: Pixels -> Int
countPixels = length . filter (== True) . A.elems

All that's left is to calculate the roughness in each transformation of the image, and return the smallest (the one with the most sea monsters).

part2 seaMonster image = minimum $ map (countRoughness seaMonster) transImages
  where imgTile = Tile 0 image
        transImages = map pixels $ transforms imgTile


You can find the code here or on GitLab.