Disk Defragmentation — Haskell — #adventofcode Day 14

📅 Friday 15 December 2017 🗂️ Technology 🗂️ Learning 🗂️ Advent of Code 🗂️ Haskell

Today’s challenge has us helping a disk defragmentation program by identifying contiguous regions of used sectors on a 2D disk.

→ Full code on GitHub

!!! commentary Wow, today’s challenge had a pretty steep learning curve. Day 14 was the first to directly reuse code from a previous day: the “knot hash” from day 10. I solved day 10 in Haskell, so I thought it would be easier to stick with Haskell for today as well. The first part was straightforward, but the second was pretty mind-bending in a pure functional language!

I ended up solving it by implementing a [flood fill algorithm][flood]. It's recursive, which is right in Haskell's wheelhouse, but I ended up using `Data.Sequence` instead of the standard list type as its API for indexing is better. I haven't tried it, but I think it will also be a little faster than a naive list-based version.

It took a looong time to figure everything out, but I had a day off work to be able to concentrate on it!

A lot more imports for this solution, as we’re exercising a lot more of the standard library.

module Main where

import Prelude hiding (length, filter, take)
import Data.Char (ord)
import Data.Sequence
import Data.Foldable hiding (length)
import Data.Ix (inRange)
import Data.Function ((&))
import Data.Maybe (fromJust, mapMaybe, isJust)
import qualified Data.Set as Set
import Text.Printf (printf)
import System.Environment (getArgs)

Also we’ll extract the key bits from day 10 into a module and import that.

import KnotHash

Now we define a few data types to make the code a bit more readable. Sector represent the state of a particular disk sector, either free, used (but unmarked) or used and marked as belonging to a given integer-labelled group. Grid is a 2D matrix of Sector, as a sequence of sequences.

data Sector = Free | Used | Mark Int
  deriving (Eq)

instance Show Sector where
  show Free = "   ."
  show Used = "   #"
  show (Mark i) = printf "%4d" i

type GridRow = Seq Sector
type Grid = Seq (GridRow)

Some utility functions to make it easier to view the grids (which can be quite large): used for debugging but not in the finished solution.

subGrid :: Int -> Grid -> Grid
subGrid n = fmap (take n) . take n

printRow :: GridRow -> IO ()
printRow row = do
  mapM_ (putStr . show) row
  putStr "\n"

printGrid :: Grid -> IO ()
printGrid = mapM_ printRow

makeKey generates the hash key for a given row.

makeKey :: String -> Int -> String
makeKey input n = input ++ "-" ++ show n

stringToGridRow converts a binary string of ‘1’ and ‘0’ characters to a sequence of Sector values.

stringToGridRow :: String -> GridRow
stringToGridRow = fromList . map convert
  where convert x
          | x == '1' = Used
          | x == '0' = Free

makeRow and makeGrid build up the grid to use based on the provided input string.

makeRow :: String -> Int -> GridRow
makeRow input n = stringToGridRow $ concatMap (printf "%08b")
  $ dense $ fullKnotHash 256
  $ map ord $ makeKey input n

makeGrid :: String -> Grid
makeGrid input = fromList $ map (makeRow input) [0..127]

Utility functions to count the number of used and free sectors, to give the solution to part 1.

countEqual :: Sector -> Grid -> Int
countEqual x = sum . fmap (length . filter (==x))

countUsed = countEqual Used
countFree = countEqual Free

Now the real meat begins! fundUnmarked finds the location of the next used sector that we haven’t yet marked. It returns a Maybe value, which is Just (x, y) if there is still an unmarked block or Nothing if there’s nothing left to mark.

findUnmarked :: Grid -> Maybe (Int, Int)
findUnmarked g
  | y == Nothing = Nothing
  | otherwise = Just (fromJust x, fromJust y)
  where
    hasUnmarked row = isJust $ elemIndexL Used row
    x = findIndexL hasUnmarked g
    y = case x of
      Nothing -> Nothing
      Just x' -> elemIndexL Used $ index g x'

floodFill implements a very simple recursive flood fill. It takes a target and replacement value and a starting location, and fills in the replacement value for every connected location that currently has the target value. We use it below to replace a connected used region with a marked region.

floodFill :: Sector -> Sector -> (Int, Int) -> Grid -> Grid
floodFill t r (x, y) g
  | inRange (0, length g - 1) x
    && inRange (0, length g - 1) y
    && elem == t =
      let newRow = update y r row
          newGrid = update x newRow g
      in newGrid
         & floodFill t r (x+1, y)
         & floodFill t r (x-1, y)
         & floodFill t r (x, y+1)
         & floodFill t r (x, y-1)
  | otherwise = g
  where
    row = g `index` x
    elem = row `index` y

markNextGroup looks for an unmarked group and marks it if found. If no more groups are found it returns Nothing. markAllGroups then repeatedly applies markNextGroup until Nothing is returned.

markNextGroup :: Int -> Grid -> Maybe Grid
markNextGroup i g = case findUnmarked g of
                      Nothing -> Nothing
                      Just loc -> Just $ floodFill Used (Mark i) loc g

markAllGroups :: Grid -> Grid
markAllGroups g = markAllGroups' 1 g
  where
    markAllGroups' i g = case markNextGroup i g of
      Nothing -> g
      Just g' -> markAllGroups' (i+1) g'

onlyMarks filters a grid row and returns a list of (possibly duplicated) group numbers in the row.

onlyMarks :: GridRow -> [Int]
onlyMarks = mapMaybe getMark . toList
  where
    getMark Free = Nothing
    getMark Used = Nothing
    getMark (Mark i) = Just i

Finally, countGroups puts all the group numbers into a set to get rid of duplicates and returns the size of the set, i.e. the total number of separate groups.

countGroups :: Grid -> Int
countGroups g = Set.size groupSet
  where
    groupSet = foldl' Set.union Set.empty $ fmap rowToSet g
    rowToSet = Set.fromList . toList . onlyMarks

As always, every Haskell program needs a main function to drive the I/O and produce the actual result.

main = do
  input <- fmap head getArgs
  let grid = makeGrid input
      used = countUsed grid
      marked = countGroups $ markAllGroups grid

  putStrLn $ "Used sectors: " ++ show used
  putStrLn $ "Groups: " ++ show marked

Webmentions

You can respond to this post, "Disk Defragmentation — Haskell — #adventofcode Day 14", by: liking, boosting or replying to a tweet or toot that mentions it; or sending a webmention from your own site to https://erambler.co.uk/blog/day-14/

Comments