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 $ 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.

    Neil Smith

    Read more posts by this author.