# Disk Defragmentation — Haskell — #adventofcode Day 14

**Date:**

**Series:**Advent of Code 2017

Series

This post is part of the series Advent of Code 2017

- Reflections on #aoc2017
- The Halting Problem — Python — #adventofcode Day 25
- Electromagnetic Moat — Rust — #adventofcode Day 24
- Coprocessor Conflagration — Haskell — #adventofcode Day 23
- Sporifica Virus — Rust — #adventofcode Day 22
- Fractal Art — Python — #adventofcode Day 21
- Particle Swarm — Python — #adventofcode Day 20
- A Series of Tubes — Rust — #adventofcode Day 19
- Duet — Haskell — #adventofcode Day 18
- Spinlock — Rust/Python — #adventofcode Day 17
- Permutation Promenade — Julia — #adventofcode Day 16
- Dueling Generators — Rust — #adventofcode Day 15
- > Disk Defragmentation — Haskell — #adventofcode Day 14 <
- Packet Scanners — Haskell — #adventofcode Day 13
- Digital Plumber — Python — #adventofcode Day 12
- Hex Ed — Python — #adventofcode Day 11
- Knot Hash — Haskell — #adventofcode Day 10
- Stream Processing — Haskell — #adventofcode Day 9
- I Heard You Like Registers — Python — #adventofcode Day 8
- Recursive Circus — Ruby — #adventofcode Day 7
- Memory Reallocation — Python — #adventofcode Day 6
- A Maze of Twisty Trampolines — C++ — #adventofcode Day 5
- High Entropy Passphrases — Python — #adventofcode Day 4
- Spiral Memory — Go — #adventofcode Day 3
- Corruption Checksum — Python — #adventofcode Day 2
- Inverse Captcha — Coconut — #adventofcode Day 1
- Advent of Code 2017: introduction

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

!!! 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

*Powered by Cactus Comments 🌵*