Day 12 had two parts with the same logic, even though it was a little bit hidden. In both parts, I have to find "connected" regions of things, so I can say both "which region is this in?" and "what are the other things in this same region?". Finding these regions is a union-find task.

Union-find

The idea is that each distinct region is represented by a single exemplar of that region. If two things are in the same region, they have the same exemplar. When I want to add a new thing to the set of regions, I find the exemplars of all its neighbours and, in turn, add this point to the same region as each of them (this could well merge regions).

I use Haskell's typeclass feature to reuse the implementation across the two parts. The key data structure here is a Map going from an element to its parent (this includes the rank, which we'll get to). An exemplar's parent is itself.

data UFElement a = UFElement a Int -- the rank
  deriving (Show, Eq, Ord)

type UFind a = M.Map a (UFElement a)

I create a new typeclass of things that can be joined in this way. The first thing I can use it with is to define the exemplar of an element by following the parent links.

class Ord a => Joinable a where

  exemplar :: UFind a -> a -> a
  exemplar uf x 
    | x == parent = x
    | otherwise = exemplar uf parent
    where UFElement parent _ = uf ! x

When I want to find the regions, I create an initial union-find map containing a lot of atomic regions. Then I take each in turn and merge it into any regions I've already found. All remaining functions below are all within this typeclass.

The start of the process is to create the atomic regions, each being its own exemplar.

ufStart :: [a] -> UFind a
ufStart xs = M.fromList [(x, UFElement x 0) | x <- xs]

join does the work. Given that we already know that x and y should be in the same region, we need to make sure their exemplars are the same. If they're already the same, we have nothing to do. If they're not, we need to make the exemplar of one point to the exemplar of the other. For efficiency, we want to keep the ancestor chains roughly balanced. The rank of a UFElement shows the longest ancestor trail leading to this element. We use that to make the lowest-rank exemplar point to the highest-ranked. If the ranks are equal, we pick one and increase its rank.

  join :: UFind a -> a -> a -> UFind a
  join uf x y
    | x' == y' = uf
    | rankX < rankY = M.insert x' (UFElement y' rankX) uf
    | rankX > rankY = M.insert y' (UFElement x' rankY) uf
    | otherwise = M.insert y' (UFElement x' rankY) $ M.insert x' newRoot uf
    where x' = exemplar uf x
          y' = exemplar uf y
          UFElement _ rankX = uf ! x'
          UFElement _ rankY = uf ! y'
          newRoot = UFElement x' (rankX + 1)

I use that to merge each item in turn, by adding it to each of regions of each of its neighbours (using the specific version of meets for each instance of the class).

merge :: UFind a -> UFind a
merge uf = foldl' mergeItem uf $ M.keys uf

mergeItem :: UFind a -> a -> UFind a
mergeItem uf x = foldl' (\u y -> join u x y) uf nbrs
  where nbrs = filter (meets x) $ M.keys uf

Once the regions are merged, I can ask for the exemplars and the members of each region.

exemplars :: UFind a -> [a]
exemplars uf = filter (\x -> x == exemplar uf x) $ M.keys uf

distinctSets :: UFind a -> [[a]]
distinctSets uf = fmap go es
  where es = exemplars uf
        go e = filter (\x -> exemplar uf x == e) $ M.keys uf

And that's the core of it done!

Part 1

Part 1 involves finding connected sets of plots.

type Position = V2 Int -- r, c
data Plot = Plot { pos :: Position, plant :: Char, fenceLength :: Int }
  deriving (Show, Eq, Ord)

type Region = [Plot]

I define the neighbours of a point.

neighbours, neighboursH, neighboursV :: Position -> [Position]
neighboursH (V2 r c) = [V2 r (c-1), V2 r (c+1)]
neighboursV (V2 r c) = [V2 (r-1) c, V2 (r+1) c]
neighbours here = neighboursH here ++ neighboursV here

With that, I can say that a plot meets another plot if one is the neighbour of the other, and they contain the same type of plant.

instance Joinable Plot where
  meets plot1 plot2 = 
    plot1.pos `elem` neighbours plot2.pos && plot1.plant == plot2.plant

I can find the number of fence fragments on each plot before I bother with finding regions.

let fenceField = fmap (findFenceLength field) field

findFenceLength :: Region -> Plot -> Plot
findFenceLength region plot = plot { fenceLength = 4 - (length nbrs) }
  where nbrs = filter (meets plot) region

I find the regions (fields?) in the set of plots by calling merge.

findRegions :: Region -> UFind Plot
findRegions field = merge $ ufStart field

Then I find the fence cost of each region.

part1 regions = sum $ fmap fenceCost $ distinctSets regions

perimeter :: Region -> Int
perimeter region = sum $ fmap fenceLength region

fenceCost :: Region -> Int
fenceCost region = (perimeter region) * (length region)

Part 2

For each region, I find the SideFragments for each plot, then merge them if they're part of the same side. The merging happens if two SideFragments have neighbouring plots and they're facing the same way.

data Facing = T | R | B | L deriving (Show, Eq, Ord)
data SideFragment = SideFragment Position Facing 
  deriving (Show, Eq, Ord)
type Side = [SideFragment]

instance Joinable SideFragment where
  meets (SideFragment p1 T) (SideFragment p2 T) = p1 `elem` neighboursH p2
  meets (SideFragment p1 B) (SideFragment p2 B) = p1 `elem` neighboursH p2
  meets (SideFragment p1 L) (SideFragment p2 L) = p1 `elem` neighboursV p2
  meets (SideFragment p1 R) (SideFragment p2 R) = p1 `elem` neighboursV p2
  meets _ _ = False

I start by finding all the side fragments for a region.

sideFragments :: Region -> Side
sideFragments region = concatMap (plotSides region) region

plotSides :: Region -> Plot -> Side
plotSides region plot = 
  [ SideFragment plot.pos f 
  | f <- [T, R, B, L]
  , (sideP f) `notElem` regionPoss
  ]
  where sideP T = plot.pos + V2 (-1) 0
        sideP R = plot.pos + V2 0 1
        sideP B = plot.pos + V2 1 0
        sideP L = plot.pos + V2 0 (-1)
        regionPoss = fmap pos region

I then, for each region, merge its side fragments. The number of sides is the number of exemplar side fragments.

part2 regionsU = sum $ zipWith bulkFenceCost regions regionSideCounts
  where regions = distinctSets regionsU
        regionSides = fmap sideFragments regions
        findSides r = exemplars $ merge $ ufStart r
        regionSideCounts = fmap (length . findSides) regionSides

Finally, the bulk fence cost.

bulkFenceCost :: Region -> Int -> Int
bulkFenceCost region nSides = (length region) * nSides

Other approaches

I initially didn't bother with the explicit union-find approach, as I built something directly for part 1 then essentially copied it for part 2. But that was very slow (about three minutes), so I re-implemented the solution as described above. It's still slow (about one minute), but good enough.

Addendum: optimising

I've written another post on this puzzle, showing how I optimised this program. It took the runtime from a minute to less than four seconds, mainly by making a couple of small changes in mergeItem.

Code

You can get the code from my locally-hosted Git repo, or from Codeberg.